Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Applications/P4⁄Mac 2.0d4/Original source & doc/pcom.p

Text File | 1994-07-28 | 114.9 KB | 4,001 lines | [TEXT/ttxt]

(*$c+,t-,d-,l-*)
 (***********************************************
  *                        *
  *     Portable Pascal compiler        *
  *     ************************        *
  *                        *
  *        Pascal P4            *
  *                        *
  *     Authors:                *
  *          Urs Ammann            *
  *          Kesav Nori            *
  *          Christian Jacobi            *
  *     Address:                *
  *      Institut Fuer Informatik        *
  *      Eidg. Technische Hochschule        *
  *      CH-8096 Zuerich            *
  *                        *
  *  This code is fully documented in the book    *
  *       "Pascal Implementation"        *
  *   by Steven Pemberton and Martin Daniels    *
  * published by Ellis Horwood, Chichester, UK    *
  *        ISBN: 0-13-653-0311            *
  *       (also available in Japanese)        *
  *                        *
  * Steven Pemberton, CWI/AA,            *
  * Kruislaan 413, 1098 SJ Amsterdam, NL    *
  * [e-mail]            *
  *                        *
  ***********************************************)

program pascalcompiler(input,output,prr);

const displimit = 20; maxlevel = 10;
   intsize     =      1;
   intal       =      1;
   realsize    =      1;
   realal      =      1;
   charsize    =      1;
   charal      =      1;
   charmax     =      1;
   boolsize    =      1;
   boolal      =      1;
   ptrsize     =      1;
   adral       =      1;
   setsize     =      1;
   setal       =      1;
   stackal     =      1;
   stackelsize =      1;
   strglgth    =     16;
   sethigh     =     47;
   setlow      =      0;
   ordmaxchar  =     63;
   ordminchar  =      0;
   maxint      =  32767;
   lcaftermarkstack = 5;
   fileal      = charal;
   (* stackelsize = minimum size for 1 stackelement
          = k*stackal
      stackal     = scm(all other al-constants)
      charmax     = scm(charsize,charal)
            scm = smallest common multiple
      lcaftermarkstack >= 4*ptrsize+max(x-size)
            = k1*stackelsize      *)
   maxstack   =       1;
   parmal     = stackal;
   parmsize   = stackelsize;
   recal      = stackal;
   filebuffer =       4;
   maxaddr    =  maxint;



type                            (*describing:*)
                                (*************)

     marktype= ^integer;
                                (*basic symbols*)
                                (***************)

     symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,relop,
           lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow,
           colon,becomes,labelsy,constsy,typesy,varsy,funcsy,progsy,
           procsy,setsy,packedsy,arraysy,recordsy,filesy,forwardsy,
           beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy,
           gotosy,endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,
           thensy,othersy);
     operator = (mul,rdiv,andop,idiv,imod,plus,minus,orop,ltop,leop,geop,gtop,
         neop,eqop,inop,noop);
     setofsys = set of symbol;
     chtp = (letter,number,special,illegal,
         chstrquo,chcolon,chperiod,chlt,chgt,chlparen,chspace);

                                (*constants*)
                                (***********)
     setty = set of setlow..sethigh;
     cstclass = (reel,pset,strg);
     csp = ^ constant;
     constant = record case cclass: cstclass of
             reel: (rval: packed array [1..strglgth] of char);
             pset: (pval: setty);
             strg: (slgth: 0..strglgth;
                sval: packed array [1..strglgth] of char)
               end;

     valu = record case intval: boolean of  (*intval never set nor tested*)
             true:  (ival: integer);
             false: (valp: csp)
           end;

                               (*data structures*)
                               (*****************)
     levrange = 0..maxlevel; addrrange = 0..maxaddr;
     structform = (scalar,subrange,pointer,power,arrays,records,files,
           tagfld,variant);
     declkind = (standard,declared);
     stp = ^ structure; ctp = ^ identifier;

     structure = packed record
           marked: boolean;   (*for test phase only*)
           size: addrrange;
           case form: structform of
             scalar:   (case scalkind: declkind of
                  declared: (fconst: ctp); standard: ());
             subrange: (rangetype: stp; min,max: valu);
             pointer:  (eltype: stp);
             power:    (elset: stp);
             arrays:   (aeltype,inxtype: stp);
             records:  (fstfld: ctp; recvar: stp);
             files:    (filtype: stp);
             tagfld:   (tagfieldp: ctp; fstvar: stp);
             variant:  (nxtvar,subvar: stp; varval: valu)
           end;

                                (*names*)
                                (*******)

     idclass = (types,konst,vars,field,proc,func);
     setofids = set of idclass;
     idkind = (actual,formal);
     alpha = packed array [1..8] of char;

     identifier = packed record
           name: alpha; llink, rlink: ctp;
           idtype: stp; next: ctp;
           case klass: idclass of
             types: ();
             konst: (values: valu);
             vars:  (vkind: idkind; vlev: levrange; vaddr: addrrange);
             field: (fldaddr: addrrange);
             proc, func:  (case pfdeckind: declkind of
                  standard: (key: 1..15);
                  declared: (pflev: levrange; pfname: integer;
                      case pfkind: idkind of
                       actual: (forwdecl, externl: boolean);
                       formal: ()))
           end;


     disprange = 0..displimit;
     where = (blck,crec,vrec,rec);

                                (*expressions*)
                                (*************)
     attrkind = (cst,varbl,expr);
     vaccess = (drct,indrct,inxd);

     attr = record typtr: stp;
          case kind: attrkind of
        cst:   (cval: valu);
        varbl: (case access: vaccess of
              drct: (vlevel: levrange; dplmt: addrrange);
              indrct: (idplmt: addrrange))
          end;

     testp = ^ testpointer;
     testpointer = packed record
             elt1,elt2 : stp;
             lasttestp : testp
           end;

                                 (*labels*)
                                 (********)
     lbp = ^ labl;
     labl = record nextlab: lbp; defined: boolean;
           labval, labname: integer
        end;

     extfilep = ^filerec;
     filerec = record filename:alpha; nextfile:extfilep end;

(*-------------------------------------------------------------------------*)

var
    prr: text; (* comment this out when compiling with pcom *)
                    (*returned by source program scanner
                     insymbol:
                     **********)

    sy: symbol;             (*last symbol*)
    op: operator;           (*classification of last symbol*)
    val: valu;              (*value of last constant*)
    lgth: integer;          (*length of last string constant*)
    id: alpha;              (*last identifier (possibly truncated)*)
    kk: 1..8;               (*nr of chars in last identifier*)
    ch: char;               (*last character*)
    eol: boolean;           (*end of line flag*)


                    (*counters:*)
                    (***********)

    chcnt: integer;         (*character counter*)
    lc,ic: addrrange;           (*data location and instruction counter*)
    linecount: integer;


                    (*switches:*)
                    (***********)

    dp,                 (*declaration part*)
    prterr,             (*to allow forward references in pointer type
                      declaration by suppressing error message*)
    list,prcode,prtables: boolean;  (*output options for
                    -- source program listing
                    -- printing symbolic code
                    -- displaying ident and struct tables
                    --> procedure option*)
    debug: boolean;


                    (*pointers:*)
                    (***********)
    parmptr,
    intptr,realptr,charptr,
    boolptr,nilptr,textptr: stp;    (*pointers to entries of standard ids*)
    utypptr,ucstptr,uvarptr,
    ufldptr,uprcptr,ufctptr,    (*pointers to entries for undeclared ids*)
    fwptr: ctp;             (*head of chain of forw decl type ids*)
    fextfilep: extfilep;        (*head of chain of external files*)
    globtestp: testp;           (*last testpointer*)


                    (*bookkeeping of declaration levels:*)
                    (************************************)

    level: levrange;        (*current static level*)
    disx,               (*level of last id searched by searchid*)
    top: disprange;         (*top of display*)

    display:            (*where:   means:*)
      array [disprange] of
    packed record           (*=blck:   id is variable id*)
      fname: ctp; flabel: lbp;  (*=crec:   id is field id in record with*)
      case occur: where of      (*     constant address*)
        crec: (clev: levrange;  (*=vrec:   id is field id in record with*)
          cdspl: addrrange);(*     variable address*)
        vrec: (vdspl: addrrange)
      end;              (* --> procedure withstatement*)


                    (*error messages:*)
                    (*****************)

    errinx: 0..10;          (*nr of errors in current source line*)
    errlist:
      array [1..10] of
    packed record pos: integer;
              nmr: 1..400
           end;



                    (*expression compilation:*)
                    (*************************)

    gattr: attr;            (*describes the expr currently compiled*)


                    (*structured constants:*)
                    (***********************)

    constbegsys,simptypebegsys,typebegsys,blockbegsys,selectsys,facbegsys,
    statbegsys,typedels: setofsys;
    chartp : array[char] of chtp;
    rw:  array [1..35(*nr. of res. words*)] of alpha;
    frw: array [1..9] of 1..36(*nr. of res. words + 1*);
    rsy: array [1..35(*nr. of res. words*)] of symbol;
    ssy: array [char] of symbol;
    rop: array [1..35(*nr. of res. words*)] of operator;
    sop: array [char] of operator;
    na:  array [1..35] of alpha;
    mn:  array [0..60] of packed array [1..4] of char;
    sna: array [1..23] of packed array [1..4] of char;
    cdx: array [0..60] of -4..+4;
    pdx: array [1..23] of -7..+7;
    ordint: array [char] of integer;

    intlabel,mxint10,digmax: integer;
(*-------------------------------------------------------------------------*)
  procedure mark(var p: marktype); begin end;
  procedure release(p: marktype); begin end;

  procedure endofline;
    var lastpos,freepos,currpos,currnmr,f,k: integer;
  begin
    if errinx > 0 then   (*output error messages*)
      begin write(output,linecount:6,' ****  ':9);
    lastpos := 0; freepos := 1;
    for k := 1 to errinx do
      begin
        with errlist[k] do
          begin currpos := pos; currnmr := nmr end;
        if currpos = lastpos then write(output,',')
        else
          begin
        while freepos < currpos do
          begin write(output,' '); freepos := freepos + 1 end;
        write(output,'^');
        lastpos := currpos
          end;
        if currnmr < 10 then f := 1
        else if currnmr < 100 then f := 2
          else f := 3;
        write(output,currnmr:f);
        freepos := freepos + f + 1
      end;
    writeln(output); errinx := 0
      end;
    linecount := linecount + 1;
    if list and (not eof(input)) then
      begin write(output,linecount:6,'  ':2);
    if dp then write(output,lc:7) else write(output,ic:7);
    write(output,' ')
      end;
    chcnt := 0
  end  (*endofline*) ;

  procedure error(ferrnr: integer);
  begin
    if errinx >= 9 then
      begin errlist[10].nmr := 255; errinx := 10 end
    else
      begin errinx := errinx + 1;
    errlist[errinx].nmr := ferrnr
      end;
    errlist[errinx].pos := chcnt
  end (*error*) ;

  procedure insymbol;
    (*read next basic symbol of source program and return its
    description in the global variables sy, op, id, val and lgth*)
    label 1,2,3;
    var i,k: integer;
    digit: packed array [1..strglgth] of char;
    string: packed array [1..strglgth] of char;
    lvp: csp; test: boolean;

    procedure nextch;
    begin if eol then
      begin if list then writeln(output); endofline
      end;
      if not eof(input) then
       begin eol := eoln(input); read(input,ch);
    if list then write(output,ch);
    chcnt := chcnt + 1
       end
      else
    begin writeln(output,'   *** eof ','encountered');
      test := false
    end
    end;

    procedure options;
    begin
      repeat nextch;
    if ch <> '*' then
      begin
        if ch = 't' then
          begin nextch; prtables := ch = '+' end
        else
          if ch = 'l' then
        begin nextch; list := ch = '+';
          if not list then writeln(output)
        end
          else
         if ch = 'd' then
           begin nextch; debug := ch = '+' end
         else
        if ch = 'c' then
          begin nextch; prcode := ch = '+' end;
        nextch
      end
      until ch <> ','
    end (*options*) ;

  begin (*insymbol*)
  1:
    repeat while ((ch = ' ') or (ch = '    ')) and not eol do nextch;
      test := eol;
      if test then nextch
    until not test;
    if chartp[ch] = illegal then
      begin sy := othersy; op := noop;
    error(399); nextch
      end
    else
    case chartp[ch] of
      letter:
    begin k := 0;
      repeat
        if k < 8 then
         begin k := k + 1; id[k] := ch end ;
        nextch
      until chartp[ch] in [special,illegal,chstrquo,chcolon,
                chperiod,chlt,chgt,chlparen,chspace];
      if k >= kk then kk := k
      else
        repeat id[kk] := ' '; kk := kk - 1
        until kk = k;
      for i := frw[k] to frw[k+1] - 1 do
        if rw[i] = id then
          begin sy := rsy[i]; op := rop[i]; goto 2 end;
        sy := ident; op := noop;
  2:    end;
      number:
    begin op := noop; i := 0;
      repeat i := i+1; if i<= digmax then digit[i] := ch; nextch
      until chartp[ch] <> number;
      if ((ch = '.') and (input^ <> '.')) or (ch = 'e') then
        begin
          k := i;
          if ch = '.' then
            begin k := k+1; if k <= digmax then digit[k] := ch;
              nextch; (*if ch = '.' then begin ch := ':'; goto 3 end;*)
              if chartp[ch] <> number then error(201)
              else
            repeat k := k + 1;
              if k <= digmax then digit[k] := ch; nextch
            until chartp[ch] <>  number
            end;
          if ch = 'e' then
            begin k := k+1; if k <= digmax then digit[k] := ch;
              nextch;
              if (ch = '+') or (ch ='-') then
            begin k := k+1; if k <= digmax then digit[k] := ch;
              nextch
            end;
              if chartp[ch] <> number then error(201)
              else
            repeat k := k+1;
              if k <= digmax then digit[k] := ch; nextch
            until chartp[ch] <> number
             end;
           new(lvp,reel); sy:= realconst; lvp^.cclass := reel;
           with lvp^ do
             begin for i := 1 to strglgth do rval[i] := ' ';
               if k <= digmax then
             for i := 2 to k + 1 do rval[i] := digit[i-1]
               else begin error(203); rval[2] := '0';
                  rval[3] := '.'; rval[4] := '0'
                end
             end;
           val.valp := lvp
        end
      else
  3:    begin
          if i > digmax then begin error(203); val.ival := 0 end
          else
        with val do
          begin ival := 0;
            for k := 1 to i do
              begin
            if ival <= mxint10 then
              ival := ival*10+ordint[digit[k]]
            else begin error(203); ival := 0 end
              end;
            sy := intconst
          end
        end
    end;
      chstrquo:
    begin lgth := 0; sy := stringconst;  op := noop;
      repeat
        repeat nextch; lgth := lgth + 1;
           if lgth <= strglgth then string[lgth] := ch
        until (eol) or (ch = '''');
        if eol then error(202) else nextch
      until ch <> '''';
      lgth := lgth - 1;   (*now lgth = nr of chars in string*)
      if lgth = 0 then error(205) else
      if lgth = 1 then val.ival := ord(string[1])
      else
        begin new(lvp,strg); lvp^.cclass:=strg;
          if lgth > strglgth then
        begin error(399); lgth := strglgth end;
          with lvp^ do
        begin slgth := lgth;
          for i := 1 to lgth do sval[i] := string[i]
        end;
          val.valp := lvp
        end
    end;
      chcolon:
    begin op := noop; nextch;
      if ch = '=' then
        begin sy := becomes; nextch end
      else sy := colon
    end;
      chperiod:
    begin op := noop; nextch;
      if ch = '.' then
        begin sy := colon; nextch end
      else sy := period
    end;
      chlt:
    begin nextch; sy := relop;
      if ch = '=' then
        begin op := leop; nextch end
      else
        if ch = '>' then
          begin op := neop; nextch end
        else op := ltop
    end;
      chgt:
    begin nextch; sy := relop;
      if ch = '=' then
        begin op := geop; nextch end
      else op := gtop
    end;
      chlparen:
       begin nextch;
     if ch = '*' then
       begin nextch;
         if ch = '$' then options;
         repeat
           while (ch <> '*') and not eof(input) do nextch;
           nextch
         until (ch = ')') or eof(input);
         nextch; goto 1
       end;
     sy := lparent; op := noop
       end;
      special:
    begin sy := ssy[ch]; op := sop[ch];
      nextch
    end;
      chspace: sy := othersy
    end (*case*)
  end (*insymbol*) ;

  procedure enterid(fcp: ctp);
    (*enter id pointed at by fcp into the name-table,
     which on each declaration level is organised as
     an unbalanced binary tree*)
    var nam: alpha; lcp, lcp1: ctp; lleft: boolean;
  begin nam := fcp^.name;
    lcp := display[top].fname;
    if lcp = nil then
      display[top].fname := fcp
    else
      begin
    repeat lcp1 := lcp;
      if lcp^.name = nam then   (*name conflict, follow right link*)
        begin error(101); lcp := lcp^.rlink; lleft := false end
      else
        if lcp^.name < nam then
          begin lcp := lcp^.rlink; lleft := false end
        else begin lcp := lcp^.llink; lleft := true end
    until lcp = nil;
    if lleft then lcp1^.llink := fcp else lcp1^.rlink := fcp
      end;
    fcp^.llink := nil; fcp^.rlink := nil
  end (*enterid*) ;

  procedure searchsection(fcp: ctp; var fcp1: ctp);
    (*to find record fields and forward declared procedure id's
     --> procedure proceduredeclaration
     --> procedure selector*)
     label 1;
  begin
    while fcp <> nil do
      if fcp^.name = id then goto 1
      else if fcp^.name < id then fcp := fcp^.rlink
    else fcp := fcp^.llink;
1:  fcp1 := fcp
  end (*searchsection*) ;

  procedure searchid(fidcls: setofids; var fcp: ctp);
    label 1;
    var lcp: ctp;
  begin
    for disx := top downto 0 do
      begin lcp := display[disx].fname;
    while lcp <> nil do
      if lcp^.name = id then
        if lcp^.klass in fidcls then goto 1
        else
          begin if prterr then error(103);
        lcp := lcp^.rlink
          end
      else
        if lcp^.name < id then
          lcp := lcp^.rlink
        else lcp := lcp^.llink
      end;
    (*search not successful; suppress error message in case
     of forward referenced type id in pointer type definition
     --> procedure simpletype*)
    if prterr then
      begin error(104);
    (*to avoid returning nil, reference an entry
     for an undeclared id of appropriate class
     --> procedure enterundecl*)
    if types in fidcls then lcp := utypptr
    else
      if vars in fidcls then lcp := uvarptr
      else
        if field in fidcls then lcp := ufldptr
        else
          if konst in fidcls then lcp := ucstptr
          else
        if proc in fidcls then lcp := uprcptr
        else lcp := ufctptr;
      end;
1:  fcp := lcp
  end (*searchid*) ;

  procedure getbounds(fsp: stp; var fmin,fmax: integer);
    (*get internal bounds of subrange or scalar type*)
    (*assume fsp<>intptr and fsp<>realptr*)
  begin
    fmin := 0; fmax := 0;
    if fsp <> nil then
    with fsp^ do
      if form = subrange then
    begin fmin := min.ival; fmax := max.ival end
      else
      if fsp = charptr then
        begin fmin := ordminchar; fmax := ordmaxchar
        end
      else
        if fconst <> nil then
          fmax := fconst^.values.ival
  end (*getbounds*) ;

  function alignquot(fsp: stp): integer;
  begin
    alignquot := 1;
    if fsp <> nil then
      with fsp^ do
    case form of
      scalar:   if fsp=intptr then alignquot := intal
            else if fsp=boolptr then alignquot := boolal
            else if scalkind=declared then alignquot := intal
            else if fsp=charptr then alignquot := charal
            else if fsp=realptr then alignquot := realal
            else (*parmptr*) alignquot := parmal;
      subrange: alignquot := alignquot(rangetype);
      pointer:  alignquot := adral;
      power:    alignquot := setal;
      files:    alignquot := fileal;
      arrays:   alignquot := alignquot(aeltype);
      records:  alignquot := recal;
      variant,tagfld: error(501)
    end
  end (*alignquot*);

  procedure align(fsp: stp; var flc: addrrange);
    var k,l: integer;
  begin
    k := alignquot(fsp);
    l := flc-1;
    flc := l + k  -  (k+l) mod k
  end (*align*);

  procedure printtables(fb: boolean);
    (*print data structure and name table*)
    var i, lim: disprange;

    procedure marker;
      (*mark data structure entries to avoid multiple printout*)
      var i: integer;

      procedure markctp(fp: ctp); forward;

      procedure markstp(fp: stp);
    (*mark data structures, prevent cycles*)
      begin
    if fp <> nil then
      with fp^ do
        begin marked := true;
          case form of
          scalar:   ;
          subrange: markstp(rangetype);
          pointer:  (*don't mark eltype: cycle possible; will be marked
            anyway, if fp = true*) ;
          power:    markstp(elset) ;
          arrays:   begin markstp(aeltype); markstp(inxtype) end;
          records:  begin markctp(fstfld); markstp(recvar) end;
          files:    markstp(filtype);
          tagfld:   markstp(fstvar);
          variant:  begin markstp(nxtvar); markstp(subvar) end
          end (*case*)
        end (*with*)
      end (*markstp*);

      procedure markctp;
      begin
    if fp <> nil then
      with fp^ do
        begin markctp(llink); markctp(rlink);
          markstp(idtype)
        end
      end (*markctp*);

    begin (*marker*)
      for i := top downto lim do
    markctp(display[i].fname)
    end (*marker*);

    procedure followctp(fp: ctp); forward;

    procedure followstp(fp: stp);
    begin
      if fp <> nil then
    with fp^ do
      if marked then
        begin marked := false; write(output,' ':4,ord(fp):6,size:10);
          case form of
          scalar:   begin write(output,'scalar':10);
              if scalkind = standard then
                write(output,'standard':10)
              else write(output,'declared':10,' ':4,ord(fconst):6);
              writeln(output)
            end;
          subrange: begin
              write(output,'subrange':10,' ':4,ord(rangetype):6);
              if rangetype <> realptr then
                write(output,min.ival,max.ival)
              else
                if (min.valp <> nil) and (max.valp <> nil) then
                  write(output,' ',min.valp^.rval:9,
                    ' ',max.valp^.rval:9);
              writeln(output); followstp(rangetype);
            end;
          pointer:  writeln(output,'pointer':10,' ':4,ord(eltype):6);
          power:    begin writeln(output,'set':10,' ':4,ord(elset):6);
              followstp(elset)
            end;
          arrays:   begin
              writeln(output,'array':10,' ':4,ord(aeltype):6,' ':4,
                ord(inxtype):6);
              followstp(aeltype); followstp(inxtype)
            end;
          records:  begin
              writeln(output,'record':10,' ':4,ord(fstfld):6,' ':4,
                ord(recvar):6); followctp(fstfld);
              followstp(recvar)
            end;
          files:    begin write(output,'file':10,' ':4,ord(filtype):6);
              followstp(filtype)
            end;
          tagfld:   begin writeln(output,'tagfld':10,' ':4,ord(tagfieldp):6,
                ' ':4,ord(fstvar):6);
              followstp(fstvar)
            end;
          variant:  begin writeln(output,'variant':10,' ':4,ord(nxtvar):6,
                ' ':4,ord(subvar):6,varval.ival);
              followstp(nxtvar); followstp(subvar)
            end
          end (*case*)
        end (*if marked*)
    end (*followstp*);

    procedure followctp;
      var i: integer;
    begin
      if fp <> nil then
    with fp^ do
      begin write(output,' ':4,ord(fp):6,' ',name:9,' ':4,ord(llink):6,
        ' ':4,ord(rlink):6,' ':4,ord(idtype):6);
        case klass of
          types: write(output,'type':10);
          konst: begin write(output,'constant':10,' ':4,ord(next):6);
               if idtype <> nil then
             if idtype = realptr then
               begin
                 if values.valp <> nil then
                   write(output,' ',values.valp^.rval:9)
               end
             else
               if idtype^.form = arrays then  (*stringconst*)
                 begin
                   if values.valp <> nil then
                 begin write(output,' ');
                   with values.valp^ do
                     for i := 1 to slgth do
                       write(output,sval[i])
                 end
                 end
               else write(output,values.ival)
             end;
          vars:  begin write(output,'variable':10);
               if vkind = actual then write(output,'actual':10)
               else write(output,'formal':10);
               write(output,' ':4,ord(next):6,vlev,' ':4,vaddr:6 );
             end;
          field: write(output,'field':10,' ':4,ord(next):6,' ':4,fldaddr:6);
          proc,
          func:  begin
               if klass = proc then write(output,'procedure':10)
               else write(output,'function':10);
               if pfdeckind = standard then
             write(output,'standard':10, key:10)
               else
             begin write(output,'declared':10,' ':4,ord(next):6);
               write(output,pflev,' ':4,pfname:6);
               if pfkind = actual then
                 begin write(output,'actual':10);
                   if forwdecl then write(output,'forward':10)
                   else write(output,'notforward':10);
                   if externl then write(output,'extern':10)
                   else write(output,'not extern':10);
                 end
               else write(output,'formal':10)
             end
             end
        end (*case*);
        writeln(output);
        followctp(llink); followctp(rlink);
        followstp(idtype)
      end (*with*)
    end (*followctp*);

  begin (*printtables*)
    writeln(output); writeln(output); writeln(output);
    if fb then lim := 0
    else begin lim := top; write(output,' local') end;
    writeln(output,' tables '); writeln(output);
    marker;
    for i := top downto lim do
      followctp(display[i].fname);
    writeln(output);
    if not eol then write(output,' ':chcnt+16)
  end (*printtables*);

  procedure genlabel(var nxtlab: integer);
  begin intlabel := intlabel + 1;
    nxtlab := intlabel
  end (*genlabel*);

  procedure block(fsys: setofsys; fsy: symbol; fprocp: ctp);
    var lsy: symbol; test: boolean;

    procedure skip(fsys: setofsys);
      (*skip input string until relevant symbol found*)
    begin
      if not eof(input) then
    begin while not(sy in fsys) and (not eof(input)) do insymbol;
      if not (sy in fsys) then insymbol
    end
    end (*skip*) ;

    procedure constant(fsys: setofsys; var fsp: stp; var fvalu: valu);
      var lsp: stp; lcp: ctp; sign: (none,pos,neg);
      lvp: csp; i: 2..strglgth;
    begin lsp := nil; fvalu.ival := 0;
      if not(sy in constbegsys) then
    begin error(50); skip(fsys+constbegsys) end;
      if sy in constbegsys then
    begin
      if sy = stringconst then
        begin
          if lgth = 1 then lsp := charptr
          else
        begin
          new(lsp,arrays);
          with lsp^ do
            begin aeltype := charptr; inxtype := nil;
               size := lgth*charsize; form := arrays
            end
        end;
          fvalu := val; insymbol
        end
      else
        begin
          sign := none;
          if (sy = addop) and (op in [plus,minus]) then
        begin if op = plus then sign := pos else sign := neg;
          insymbol
        end;
          if sy = ident then
        begin searchid([konst],lcp);
          with lcp^ do
            begin lsp := idtype; fvalu := values end;
          if sign <> none then
            if lsp = intptr then
              begin if sign = neg then fvalu.ival := -fvalu.ival end
            else
              if lsp = realptr then
            begin
              if sign = neg then
                begin new(lvp,reel);
                  if fvalu.valp^.rval[1] = '-' then
                lvp^.rval[1] := '+'
                  else lvp^.rval[1] := '-';
                  for i := 2 to strglgth do
                lvp^.rval[i] := fvalu.valp^.rval[i];
                  fvalu.valp := lvp;
                end
              end
            else error(105);
          insymbol;
        end
          else
        if sy = intconst then
          begin if sign = neg then val.ival := -val.ival;
            lsp := intptr; fvalu := val; insymbol
          end
        else
          if sy = realconst then
            begin if sign = neg then val.valp^.rval[1] := '-';
              lsp := realptr; fvalu := val; insymbol
            end
          else
            begin error(106); skip(fsys) end
        end;
      if not (sy in fsys) then
        begin error(6); skip(fsys) end
      end;
      fsp := lsp
    end (*constant*) ;

    function equalbounds(fsp1,fsp2: stp): boolean;
      var lmin1,lmin2,lmax1,lmax2: integer;
    begin
      if (fsp1=nil) or (fsp2=nil) then equalbounds := true
      else
    begin
      getbounds(fsp1,lmin1,lmax1);
      getbounds(fsp2,lmin2,lmax2);
      equalbounds := (lmin1=lmin2) and (lmax1=lmax2)
    end
    end (*equalbounds*) ;

    function comptypes(fsp1,fsp2: stp) : boolean;
      (*decide whether structures pointed at by fsp1 and fsp2 are compatible*)
      var nxt1,nxt2: ctp; comp: boolean;
    ltestp1,ltestp2 : testp;
    begin
      if fsp1 = fsp2 then comptypes := true
      else
    if (fsp1 <> nil) and (fsp2 <> nil) then
      if fsp1^.form = fsp2^.form then
        case fsp1^.form of
          scalar:
        comptypes := false;
        (* identical scalars declared on different levels are
         not recognized to be compatible*)
          subrange:
        comptypes := comptypes(fsp1^.rangetype,fsp2^.rangetype);
          pointer:
          begin
            comp := false; ltestp1 := globtestp;
            ltestp2 := globtestp;
            while ltestp1 <> nil do
              with ltestp1^ do
            begin
              if (elt1 = fsp1^.eltype) and
                 (elt2 = fsp2^.eltype) then comp := true;
              ltestp1 := lasttestp
            end;
            if not comp then
              begin new(ltestp1);
            with ltestp1^ do
              begin elt1 := fsp1^.eltype;
                elt2 := fsp2^.eltype;
                lasttestp := globtestp
              end;
            globtestp := ltestp1;
            comp := comptypes(fsp1^.eltype,fsp2^.eltype)
              end;
            comptypes := comp; globtestp := ltestp2
          end;
          power:
        comptypes := comptypes(fsp1^.elset,fsp2^.elset);
          arrays:
        begin
          comp := comptypes(fsp1^.aeltype,fsp2^.aeltype)
              and comptypes(fsp1^.inxtype,fsp2^.inxtype);
          comptypes := comp and (fsp1^.size = fsp2^.size) and
              equalbounds(fsp1^.inxtype,fsp2^.inxtype)
        end;
          records:
        begin nxt1 := fsp1^.fstfld; nxt2 := fsp2^.fstfld; comp:=true;
          while (nxt1 <> nil) and (nxt2 <> nil) do
            begin comp:=comp and comptypes(nxt1^.idtype,nxt2^.idtype);
              nxt1 := nxt1^.next; nxt2 := nxt2^.next
            end;
          comptypes := comp and (nxt1 = nil) and (nxt2 = nil)
                  and(fsp1^.recvar = nil)and(fsp2^.recvar = nil)
        end;
        (*identical records are recognized to be compatible
         iff no variants occur*)
          files:
        comptypes := comptypes(fsp1^.filtype,fsp2^.filtype)
        end (*case*)
      else (*fsp1^.form <> fsp2^.form*)
        if fsp1^.form = subrange then
          comptypes := comptypes(fsp1^.rangetype,fsp2)
        else
          if fsp2^.form = subrange then
        comptypes := comptypes(fsp1,fsp2^.rangetype)
          else comptypes := false
    else comptypes := true
    end (*comptypes*) ;

    function string(fsp: stp) : boolean;
    begin string := false;
      if fsp <> nil then
    if fsp^.form = arrays then
      if comptypes(fsp^.aeltype,charptr) then string := true
    end (*string*) ;

    procedure typ(fsys: setofsys; var fsp: stp; var fsize: addrrange);
      var lsp,lsp1,lsp2: stp; oldtop: disprange; lcp: ctp;
      lsize,displ: addrrange; lmin,lmax: integer;

      procedure simpletype(fsys:setofsys; var fsp:stp; var fsize:addrrange);
    var lsp,lsp1: stp; lcp,lcp1: ctp; ttop: disprange;
        lcnt: integer; lvalu: valu;
      begin fsize := 1;
    if not (sy in simptypebegsys) then
      begin error(1); skip(fsys + simptypebegsys) end;
    if sy in simptypebegsys then
      begin
        if sy = lparent then
          begin ttop := top;   (*decl. consts local to innermost block*)
        while display[top].occur <> blck do top := top - 1;
        new(lsp,scalar,declared);
        with lsp^ do
          begin size := intsize; form := scalar;
            scalkind := declared
          end;
        lcp1 := nil; lcnt := 0;
        repeat insymbol;
          if sy = ident then
            begin new(lcp,konst);
              with lcp^ do
            begin name := id; idtype := lsp; next := lcp1;
              values.ival := lcnt; klass := konst
            end;
              enterid(lcp);
              lcnt := lcnt + 1;
              lcp1 := lcp; insymbol
            end
          else error(2);
          if not (sy in fsys + [comma,rparent]) then
            begin error(6); skip(fsys + [comma,rparent]) end
        until sy <> comma;
        lsp^.fconst := lcp1; top := ttop;
        if sy = rparent then insymbol else error(4)
          end
        else
          begin
        if sy = ident then
          begin searchid([types,konst],lcp);
            insymbol;
            if lcp^.klass = konst then
              begin new(lsp,subrange);
            with lsp^, lcp^ do
              begin rangetype := idtype; form := subrange;
                if string(rangetype) then
                  begin error(148); rangetype := nil end;
                min := values; size := intsize
              end;
            if sy = colon then insymbol else error(5);
            constant(fsys,lsp1,lvalu);
            lsp^.max := lvalu;
            if lsp^.rangetype <> lsp1 then error(107)
              end
            else
              begin lsp := lcp^.idtype;
            if lsp <> nil then fsize := lsp^.size
              end
          end (*sy = ident*)
        else
          begin new(lsp,subrange); lsp^.form := subrange;
            constant(fsys + [colon],lsp1,lvalu);
            if string(lsp1) then
              begin error(148); lsp1 := nil end;
            with lsp^ do
              begin rangetype:=lsp1; min:=lvalu; size:=intsize end;
            if sy = colon then insymbol else error(5);
            constant(fsys,lsp1,lvalu);
            lsp^.max := lvalu;
            if lsp^.rangetype <> lsp1 then error(107)
          end;
        if lsp <> nil then
          with lsp^ do
            if form = subrange then
              if rangetype <> nil then
            if rangetype = realptr then error(399)
            else
              if min.ival > max.ival then error(102)
          end;
        fsp := lsp;
        if not (sy in fsys) then
          begin error(6); skip(fsys) end
      end
        else fsp := nil
      end (*simpletype*) ;

      procedure fieldlist(fsys: setofsys; var frecvar: stp);
    var lcp,lcp1,nxt,nxt1: ctp; lsp,lsp1,lsp2,lsp3,lsp4: stp;
        minsize,maxsize,lsize: addrrange; lvalu: valu;
      begin nxt1 := nil; lsp := nil;
    if not (sy in (fsys+[ident,casesy])) then
      begin error(19); skip(fsys + [ident,casesy]) end;
    while sy = ident do
      begin nxt := nxt1;
        repeat
          if sy = ident then
        begin new(lcp,field);
          with lcp^ do
            begin name := id; idtype := nil; next := nxt;
              klass := field
            end;
          nxt := lcp;
          enterid(lcp);
          insymbol
        end
          else error(2);
          if not (sy in [comma,colon]) then
        begin error(6); skip(fsys + [comma,colon,semicolon,casesy])
        end;
          test := sy <> comma;
          if not test  then insymbol
        until test;
        if sy = colon then insymbol else error(5);
        typ(fsys + [casesy,semicolon],lsp,lsize);
        while nxt <> nxt1 do
          with nxt^ do
        begin align(lsp,displ);
          idtype := lsp; fldaddr := displ;
          nxt := next; displ := displ + lsize
        end;
        nxt1 := lcp;
        while sy = semicolon do
          begin insymbol;
        if not (sy in fsys + [ident,casesy,semicolon]) then
          begin error(19); skip(fsys + [ident,casesy]) end
          end
      end (*while*);
    nxt := nil;
    while nxt1 <> nil do
      with nxt1^ do
        begin lcp := next; next := nxt; nxt := nxt1; nxt1 := lcp end;
    if sy = casesy then
      begin new(lsp,tagfld);
        with lsp^ do
          begin tagfieldp := nil; fstvar := nil; form:=tagfld end;
        frecvar := lsp;
        insymbol;
        if sy = ident then
          begin new(lcp,field);
        with lcp^ do
          begin name := id; idtype := nil; klass:=field;
            next := nil; fldaddr := displ
          end;
        enterid(lcp);
        insymbol;
        if sy = colon then insymbol else error(5);
        if sy = ident then
          begin searchid([types],lcp1);
            lsp1 := lcp1^.idtype;
            if lsp1 <> nil then
              begin align(lsp1,displ);
            lcp^.fldaddr := displ;
            displ := displ+lsp1^.size;
            if (lsp1^.form <= subrange) or string(lsp1) then
              begin if comptypes(realptr,lsp1) then error(109)
                else if string(lsp1) then error(399);
                lcp^.idtype := lsp1; lsp^.tagfieldp := lcp;
              end
            else error(110);
              end;
            insymbol;
          end
        else begin error(2); skip(fsys + [ofsy,lparent]) end
          end
        else begin error(2); skip(fsys + [ofsy,lparent]) end;
        lsp^.size := displ;
        if sy = ofsy then insymbol else error(8);
        lsp1 := nil; minsize := displ; maxsize := displ;
        repeat lsp2 := nil;
          if not (sy in fsys + [semicolon]) then
          begin
        repeat constant(fsys + [comma,colon,lparent],lsp3,lvalu);
          if lsp^.tagfieldp <> nil then
           if not comptypes(lsp^.tagfieldp^.idtype,lsp3)then error(111);
          new(lsp3,variant);
          with lsp3^ do
            begin nxtvar := lsp1; subvar := lsp2; varval := lvalu;
              form := variant
            end;
          lsp4 := lsp1;
          while lsp4 <> nil do
            with lsp4^ do
              begin
            if varval.ival = lvalu.ival then error(178);
            lsp4 := nxtvar
              end;
          lsp1 := lsp3; lsp2 := lsp3;
          test := sy <> comma;
          if not test then insymbol
        until test;
        if sy = colon then insymbol else error(5);
        if sy = lparent then insymbol else error(9);
        fieldlist(fsys + [rparent,semicolon],lsp2);
        if displ > maxsize then maxsize := displ;
        while lsp3 <> nil do
          begin lsp4 := lsp3^.subvar; lsp3^.subvar := lsp2;
            lsp3^.size := displ;
            lsp3 := lsp4
          end;
        if sy = rparent then
          begin insymbol;
            if not (sy in fsys + [semicolon]) then
              begin error(6); skip(fsys + [semicolon]) end
          end
        else error(4);
          end;
          test := sy <> semicolon;
          if not test then
        begin displ := minsize;
              insymbol
        end
        until test;
        displ := maxsize;
        lsp^.fstvar := lsp1;
      end
    else frecvar := nil
      end (*fieldlist*) ;

    begin (*typ*)
      if not (sy in typebegsys) then
     begin error(10); skip(fsys + typebegsys) end;
      if sy in typebegsys then
    begin
      if sy in simptypebegsys then simpletype(fsys,fsp,fsize)
      else
    (*^*)     if sy = arrow then
          begin new(lsp,pointer); fsp := lsp;
        with lsp^ do
          begin eltype := nil; size := ptrsize; form:=pointer end;
        insymbol;
        if sy = ident then
          begin prterr := false; (*no error if search not successful*)
            searchid([types],lcp); prterr := true;
            if lcp = nil then   (*forward referenced type id*)
              begin new(lcp,types);
            with lcp^ do
              begin name := id; idtype := lsp;
                next := fwptr; klass := types
              end;
            fwptr := lcp
              end
            else
              begin
            if lcp^.idtype <> nil then
              if lcp^.idtype^.form = files then error(108)
              else lsp^.eltype := lcp^.idtype
              end;
            insymbol;
          end
        else error(2);
          end
        else
          begin
        if sy = packedsy then
          begin insymbol;
            if not (sy in typedels) then
              begin
            error(10); skip(fsys + typedels)
              end
          end;
    (*array*)     if sy = arraysy then
          begin insymbol;
            if sy = lbrack then insymbol else error(11);
            lsp1 := nil;
            repeat new(lsp,arrays);
              with lsp^ do
            begin aeltype := lsp1; inxtype := nil; form:=arrays end;
              lsp1 := lsp;
              simpletype(fsys + [comma,rbrack,ofsy],lsp2,lsize);
              lsp1^.size := lsize;
              if lsp2 <> nil then
            if lsp2^.form <= subrange then
              begin
                if lsp2 = realptr then
                  begin error(109); lsp2 := nil end
                else
                  if lsp2 = intptr then
                begin error(149); lsp2 := nil end;
                lsp^.inxtype := lsp2
              end
            else begin error(113); lsp2 := nil end;
              test := sy <> comma;
              if not test then insymbol
            until test;
            if sy = rbrack then insymbol else error(12);
            if sy = ofsy then insymbol else error(8);
            typ(fsys,lsp,lsize);
            repeat
              with lsp1^ do
            begin lsp2 := aeltype; aeltype := lsp;
              if inxtype <> nil then
                begin getbounds(inxtype,lmin,lmax);
                  align(lsp,lsize);
                  lsize := lsize*(lmax - lmin + 1);
                  size := lsize
                end
            end;
              lsp := lsp1; lsp1 := lsp2
            until lsp1 = nil
          end
        else
    (*record*)      if sy = recordsy then
            begin insymbol;
              oldtop := top;
              if top < displimit then
            begin top := top + 1;
              with display[top] do
                begin fname := nil;
                  flabel := nil;
                  occur := rec
                end
            end
              else error(250);
              displ := 0;
              fieldlist(fsys-[semicolon]+[endsy],lsp1);
              new(lsp,records);
              with lsp^ do
            begin fstfld := display[top].fname;
              recvar := lsp1; size := displ; form := records
            end;
              top := oldtop;
              if sy = endsy then insymbol else error(13)
            end
          else
    (*set*)       if sy = setsy then
              begin insymbol;
            if sy = ofsy then insymbol else error(8);
            simpletype(fsys,lsp1,lsize);
            if lsp1 <> nil then
              if lsp1^.form > subrange then
                begin error(115); lsp1 := nil end
              else
                if lsp1 = realptr then
                  begin error(114); lsp1 := nil end
                else if lsp1 = intptr then
                  begin error(169); lsp1 := nil end
                else
                  begin getbounds(lsp1,lmin,lmax);
                if (lmin < setlow) or (lmax > sethigh)
                  then error(169);
                  end;
            new(lsp,power);
            with lsp^ do
              begin elset:=lsp1; size:=setsize; form:=power end;
              end
            else
    (*file*)        if sy = filesy then
              begin insymbol;
                error(399); skip(fsys); lsp := nil
              end;
        fsp := lsp
          end;
      if not (sy in fsys) then
        begin error(6); skip(fsys) end
    end
      else fsp := nil;
      if fsp = nil then fsize := 1 else fsize := fsp^.size
    end (*typ*) ;

    procedure labeldeclaration;
      var llp: lbp; redef: boolean; lbname: integer;
    begin
      repeat
    if sy = intconst then
      with display[top] do
        begin llp := flabel; redef := false;
          while (llp <> nil) and not redef do
        if llp^.labval <> val.ival then
          llp := llp^.nextlab
        else begin redef := true; error(166) end;
          if not redef then
        begin new(llp);
          with llp^ do
            begin labval := val.ival; genlabel(lbname);
              defined := false; nextlab := flabel; labname := lbname
            end;
          flabel := llp
        end;
          insymbol
        end
    else error(15);
    if not ( sy in fsys + [comma, semicolon] ) then
      begin error(6); skip(fsys+[comma,semicolon]) end;
    test := sy <> comma;
    if not test then insymbol
      until test;
      if sy = semicolon then insymbol else error(14)
    end (* labeldeclaration *) ;

    procedure constdeclaration;
      var lcp: ctp; lsp: stp; lvalu: valu;
    begin
      if sy <> ident then
    begin error(2); skip(fsys + [ident]) end;
      while sy = ident do
    begin new(lcp,konst);
      with lcp^ do
        begin name := id; idtype := nil; next := nil; klass:=konst end;
      insymbol;
      if (sy = relop) and (op = eqop) then insymbol else error(16);
      constant(fsys + [semicolon],lsp,lvalu);
      enterid(lcp);
      lcp^.idtype := lsp; lcp^.values := lvalu;
      if sy = semicolon then
        begin insymbol;
          if not (sy in fsys + [ident]) then
        begin error(6); skip(fsys + [ident]) end
        end
      else error(14)
    end
    end (*constdeclaration*) ;

    procedure typedeclaration;
      var lcp,lcp1,lcp2: ctp; lsp: stp; lsize: addrrange;
    begin
      if sy <> ident then
    begin error(2); skip(fsys + [ident]) end;
      while sy = ident do
    begin new(lcp,types);
      with lcp^ do
        begin name := id; idtype := nil; klass := types end;
      insymbol;
      if (sy = relop) and (op = eqop) then insymbol else error(16);
      typ(fsys + [semicolon],lsp,lsize);
      enterid(lcp);
      lcp^.idtype := lsp;
      (*has any forward reference been satisfied:*)
      lcp1 := fwptr;
      while lcp1 <> nil do
        begin
          if lcp1^.name = lcp^.name then
        begin lcp1^.idtype^.eltype := lcp^.idtype;
          if lcp1 <> fwptr then
            lcp2^.next := lcp1^.next
          else fwptr := lcp1^.next;
        end
          else lcp2 := lcp1;
          lcp1 := lcp1^.next
        end;
      if sy = semicolon then
        begin insymbol;
          if not (sy in fsys + [ident]) then
        begin error(6); skip(fsys + [ident]) end
        end
      else error(14)
    end;
      if fwptr <> nil then
    begin error(117); writeln(output);
      repeat writeln(output,' type-id ',fwptr^.name);
        fwptr := fwptr^.next
      until fwptr = nil;
      if not eol then write(output,' ': chcnt+16)
    end
    end (*typedeclaration*) ;

    procedure vardeclaration;
      var lcp,nxt: ctp; lsp: stp; lsize: addrrange;
    begin nxt := nil;
      repeat
    repeat
      if sy = ident then
        begin new(lcp,vars);
          with lcp^ do
           begin name := id; next := nxt; klass := vars;
          idtype := nil; vkind := actual; vlev := level
        end;
          enterid(lcp);
          nxt := lcp;
          insymbol;
        end
      else error(2);
      if not (sy in fsys + [comma,colon] + typedels) then
        begin error(6); skip(fsys+[comma,colon,semicolon]+typedels) end;
      test := sy <> comma;
      if not test then insymbol
    until test;
    if sy = colon then insymbol else error(5);
    typ(fsys + [semicolon] + typedels,lsp,lsize);
    while nxt <> nil do
      with  nxt^ do
        begin align(lsp,lc);
          idtype := lsp; vaddr := lc;
          lc := lc + lsize; nxt := next
        end;
    if sy = semicolon then
      begin insymbol;
        if not (sy in fsys + [ident]) then
          begin error(6); skip(fsys + [ident]) end
      end
    else error(14)
      until (sy <> ident) and not (sy in typedels);
      if fwptr <> nil then
    begin error(117); writeln(output);
      repeat writeln(output,' type-id ',fwptr^.name);
        fwptr := fwptr^.next
      until fwptr = nil;
      if not eol then write(output,' ': chcnt+16)
    end
    end (*vardeclaration*) ;

    procedure procdeclaration(fsy: symbol);
      var oldlev: 0..maxlevel; lcp,lcp1: ctp; lsp: stp;
      forw: boolean; oldtop: disprange;
      llc,lcm: addrrange; lbname: integer; markp: marktype;

      procedure parameterlist(fsy: setofsys; var fpar: ctp);
    var lcp,lcp1,lcp2,lcp3: ctp; lsp: stp; lkind: idkind;
      llc,lsize: addrrange; count: integer;
      begin lcp1 := nil;
    if not (sy in fsy + [lparent]) then
      begin error(7); skip(fsys + fsy + [lparent]) end;
    if sy = lparent then
      begin if forw then error(119);
        insymbol;
        if not (sy in [ident,varsy,procsy,funcsy]) then
          begin error(7); skip(fsys + [ident,rparent]) end;
        while sy in [ident,varsy,procsy,funcsy] do
          begin
        if sy = procsy then
          begin error(399);
            repeat insymbol;
              if sy = ident then
            begin new(lcp,proc,declared,formal);
              with lcp^ do
                begin name := id; idtype := nil; next := lcp1;
                  pflev := level (*beware of parameter procedures*);
                  klass:=proc;pfdeckind:=declared;pfkind:=formal
                end;
              enterid(lcp);
              lcp1 := lcp;
              align(parmptr,lc);
              (*lc := lc + some size *)
              insymbol
            end
              else error(2);
              if not (sy in fsys + [comma,semicolon,rparent]) then
            begin error(7);skip(fsys+[comma,semicolon,rparent])end
            until sy <> comma
          end
        else
          begin
            if sy = funcsy then
              begin error(399); lcp2 := nil;
            repeat insymbol;
              if sy = ident then
                begin new(lcp,func,declared,formal);
                  with lcp^ do
                begin name := id; idtype := nil; next := lcp2;
                  pflev := level (*beware param funcs*);
                  klass:=func;pfdeckind:=declared;
                  pfkind:=formal
                end;
                  enterid(lcp);
                 lcp2 := lcp;
                 align(parmptr,lc);
                 (*lc := lc + some size*)
                  insymbol;
                end;
              if not (sy in [comma,colon] + fsys) then
                begin error(7);skip(fsys+[comma,semicolon,rparent])
                end
            until sy <> comma;
            if sy = colon then
              begin insymbol;
                if sy = ident then
                  begin searchid([types],lcp);
                lsp := lcp^.idtype;
                if lsp <> nil then
                 if not(lsp^.form in[scalar,subrange,pointer])
                    then begin error(120); lsp := nil end;
                lcp3 := lcp2;
                while lcp2 <> nil do
                  begin lcp2^.idtype := lsp; lcp := lcp2;
                    lcp2 := lcp2^.next
                  end;
                lcp^.next := lcp1; lcp1 := lcp3;
                insymbol
                  end
                else error(2);
                if not (sy in fsys + [semicolon,rparent]) then
                  begin error(7);skip(fsys+[semicolon,rparent])end
              end
            else error(5)
              end
            else
              begin
            if sy = varsy then
              begin lkind := formal; insymbol end
            else lkind := actual;
            lcp2 := nil;
            count := 0;
            repeat
              if sy = ident then
                begin new(lcp,vars);
                  with lcp^ do
                begin name:=id; idtype:=nil; klass:=vars;
                  vkind := lkind; next := lcp2; vlev := level;
                end;
                  enterid(lcp);
                  lcp2 := lcp; count := count+1;
                  insymbol;
                end;
              if not (sy in [comma,colon] + fsys) then
                begin error(7);skip(fsys+[comma,semicolon,rparent])
                end;
              test := sy <> comma;
              if not test then insymbol
            until test;
            if sy = colon then
              begin insymbol;
                if sy = ident then
                  begin searchid([types],lcp);
                lsp := lcp^.idtype;
                lsize := ptrsize;
                if lsp <> nil then
                  if lkind=actual then
                    if lsp^.form<=power then lsize := lsp^.size
                    else if lsp^.form=files then error(121);
                align(parmptr,lsize);
                lcp3 := lcp2;
                align(parmptr,lc);
                lc := lc+count*lsize;
                llc := lc;
                while lcp2 <> nil do
                  begin lcp := lcp2;
                    with lcp2^ do
                      begin idtype := lsp;
                    llc := llc-lsize;
                    vaddr := llc;
                      end;
                    lcp2 := lcp2^.next
                  end;
                lcp^.next := lcp1; lcp1 := lcp3;
                insymbol
                  end
                else error(2);
                if not (sy in fsys + [semicolon,rparent]) then
                  begin error(7);skip(fsys+[semicolon,rparent])end
              end
            else error(5);
              end;
          end;
        if sy = semicolon then
          begin insymbol;
            if not (sy in fsys + [ident,varsy,procsy,funcsy]) then
              begin error(7); skip(fsys + [ident,rparent]) end
          end
          end (*while*) ;
        if sy = rparent then
          begin insymbol;
        if not (sy in fsy + fsys) then
          begin error(6); skip(fsy + fsys) end
          end
        else error(4);
        lcp3 := nil;
        (*reverse pointers and reserve local cells for copies of multiple
         values*)
        while lcp1 <> nil do
          with lcp1^ do
        begin lcp2 := next; next := lcp3;
          if klass = vars then
            if idtype <> nil then
              if (vkind=actual)and(idtype^.form>power) then
            begin align(idtype,lc);
              vaddr := lc;
              lc := lc+idtype^.size;
            end;
          lcp3 := lcp1; lcp1 := lcp2
        end;
        fpar := lcp3
      end
        else fpar := nil
    end (*parameterlist*) ;

    begin (*procdeclaration*)
      llc := lc; lc := lcaftermarkstack; forw := false;
      if sy = ident then
    begin searchsection(display[top].fname,lcp); (*decide whether forw.*)
      if lcp <> nil then
        begin
          if lcp^.klass = proc then
        forw := lcp^.forwdecl and(fsy=procsy)and(lcp^.pfkind=actual)
          else
        if lcp^.klass = func then
          forw:=lcp^.forwdecl and(fsy=funcsy)and(lcp^.pfkind=actual)
        else forw := false;
          if not forw then error(160)
        end;
      if not forw then
        begin
          if fsy = procsy then new(lcp,proc,declared,actual)
          else new(lcp,func,declared,actual);
          with lcp^ do
        begin name := id; idtype := nil;
          externl := false; pflev := level; genlabel(lbname);
          pfdeckind := declared; pfkind := actual; pfname := lbname;
          if fsy = procsy then klass := proc
          else klass := func
        end;
          enterid(lcp)
        end
      else
        begin lcp1 := lcp^.next;
          while lcp1 <> nil do
        begin
          with lcp1^ do
            if klass = vars then
              if idtype <> nil then
            begin lcm := vaddr + idtype^.size;
              if lcm > lc then lc := lcm
            end;
          lcp1 := lcp1^.next
        end
        end;
      insymbol
    end
      else
    begin error(2); lcp := ufctptr end;
      oldlev := level; oldtop := top;
      if level < maxlevel then level := level + 1 else error(251);
      if top < displimit then
    begin top := top + 1;
      with display[top] do
        begin
          if forw then fname := lcp^.next
          else fname := nil;
          flabel := nil;
          occur := blck
        end
    end
      else error(250);
      if fsy = procsy then
    begin parameterlist([semicolon],lcp1);
      if not forw then lcp^.next := lcp1
    end
      else
    begin parameterlist([semicolon,colon],lcp1);
      if not forw then lcp^.next := lcp1;
      if sy = colon then
        begin insymbol;
          if sy = ident then
        begin if forw then error(122);
          searchid([types],lcp1);
          lsp := lcp1^.idtype;
          lcp^.idtype := lsp;
          if lsp <> nil then
            if not (lsp^.form in [scalar,subrange,pointer]) then
              begin error(120); lcp^.idtype := nil end;
          insymbol
        end
          else begin error(2); skip(fsys + [semicolon]) end
        end
      else
        if not forw then error(123)
    end;
      if sy = semicolon then insymbol else error(14);
      if sy = forwardsy then
    begin
      if forw then error(161)
      else lcp^.forwdecl := true;
      insymbol;
      if sy = semicolon then insymbol else error(14);
      if not (sy in fsys) then
        begin error(6); skip(fsys) end
    end
      else
    begin lcp^.forwdecl := false; mark(markp);
      repeat block(fsys,semicolon,lcp);
        if sy = semicolon then
          begin if prtables then printtables(false); insymbol;
        if not (sy in [beginsy,procsy,funcsy]) then
          begin error(6); skip(fsys) end
          end
        else error(14)
      until (sy in [beginsy,procsy,funcsy]) or eof(input);
      release(markp); (* return local entries on runtime heap *)
    end;
      level := oldlev; top := oldtop; lc := llc;
    end (*procdeclaration*) ;

    procedure body(fsys: setofsys);
      const cstoccmax=65; cixmax=1000;
      type oprange = 0..63;
      var
      llcp:ctp; saveid:alpha;
      cstptr: array [1..cstoccmax] of csp;
      cstptrix: 0..cstoccmax;
      (*allows referencing of noninteger constants by an index
       (instead of a pointer), which can be stored in the p2-field
       of the instruction record until writeout.
       --> procedure load, procedure writeout*)
      entname, segsize: integer;
      stacktop, topnew, topmax: integer;
      lcmax,llc1: addrrange; lcp: ctp;
      llp: lbp;


      procedure mes(i: integer);
      begin topnew := topnew + cdx[i]*maxstack;
    if topnew > topmax then topmax := topnew
      end;

      procedure putic;
      begin if ic mod 10 = 0 then writeln(prr,'i',ic:5) end;

      procedure gen0(fop: oprange);
      begin
    if prcode then begin putic; writeln(prr,mn[fop]:4) end;
    ic := ic + 1; mes(fop)
      end (*gen0*) ;

      procedure gen1(fop: oprange; fp2: integer);
    var k: integer;
      begin
    if prcode then
      begin putic; write(prr,mn[fop]:4);
        if fop = 30 then
          begin writeln(prr,sna[fp2]:12);
        topnew := topnew + pdx[fp2]*maxstack;
        if topnew > topmax then topmax := topnew
          end
        else
          begin
        if fop = 38 then
           begin write(prr,'''');
             with cstptr[fp2]^ do
             begin
               for k := 1 to slgth do write(prr,sval[k]:1);
               for k := slgth+1 to strglgth do write(prr,' ');
             end;
             writeln(prr,'''')
           end
        else if fop = 42 then writeln(prr,chr(fp2))
             else writeln(prr,fp2:12);
        mes(fop)
          end
      end;
    ic := ic + 1
      end (*gen1*) ;

      procedure gen2(fop: oprange; fp1,fp2: integer);
    var k : integer;
      begin
    if prcode then
      begin putic; write(prr,mn[fop]:4);
        case fop of
          45,50,54,56:
        writeln(prr,' ',fp1:3,fp2:8);
          47,48,49,52,53,55:
        begin write(prr,chr(fp1));
          if chr(fp1) = 'm' then write(prr,fp2:11);
          writeln(prr)
        end;
          51:
        case fp1 of
          1: writeln(prr,'i ',fp2);
          2: begin write(prr,'r ');
               with cstptr[fp2]^ do
             for k := 1 to strglgth do write(prr,rval[k]);
               writeln(prr)
             end;
          3: writeln(prr,'b ',fp2);
          4: writeln(prr,'n');
          6: writeln(prr,'c ''':3,chr(fp2),'''');
          5: begin write(prr,'(');
               with cstptr[fp2]^ do
             for k := setlow to sethigh do
               if k in pval then write(prr,k:3);
               writeln(prr,')')
             end
        end
        end;
      end;
    ic := ic + 1; mes(fop)
      end (*gen2*) ;

      procedure gentypindicator(fsp: stp);
      begin
    if fsp<>nil then
      with fsp^ do
        case form of
         scalar: if fsp=intptr then write(prr,'i')
             else
               if fsp=boolptr then write(prr,'b')
               else
             if fsp=charptr then write(prr,'c')
             else
               if scalkind = declared then write(prr,'i')
               else write(prr,'r');
         subrange: gentypindicator(rangetype);
         pointer:  write(prr,'a');
         power:    write(prr,'s');
         records,arrays: write(prr,'m');
         files,tagfld,variant: error(500)
        end
      end (*typindicator*);

      procedure gen0t(fop: oprange; fsp: stp);
      begin
    if prcode then
      begin putic;
        write(prr,mn[fop]:4);
        gentypindicator(fsp);
        writeln(prr);
      end;
    ic := ic + 1; mes(fop)
      end (*gen0t*);

      procedure gen1t(fop: oprange; fp2: integer; fsp: stp);
      begin
    if prcode then
      begin putic;
        write(prr,mn[fop]:4);
        gentypindicator(fsp);
        writeln(prr,fp2:11)
      end;
    ic := ic + 1; mes(fop)
      end (*gen1t*);

      procedure gen2t(fop: oprange; fp1,fp2: integer; fsp: stp);
      begin
    if prcode then
      begin putic;
        write(prr,mn[fop]: 4);
        gentypindicator(fsp);
        writeln(prr,fp1:3+5*ord(abs(fp1)>99),fp2:8);
      end;
    ic := ic + 1; mes(fop)
      end (*gen2t*);

      procedure load;
      begin
    with gattr do
      if typtr <> nil then
        begin
          case kind of
        cst:   if (typtr^.form = scalar) and (typtr <> realptr) then
             if typtr = boolptr then gen2(51(*ldc*),3,cval.ival)
             else
               if typtr=charptr then
                 gen2(51(*ldc*),6,cval.ival)
               else gen2(51(*ldc*),1,cval.ival)
               else
             if typtr = nilptr then gen2(51(*ldc*),4,0)
             else
               if cstptrix >= cstoccmax then error(254)
               else
                 begin cstptrix := cstptrix + 1;
                   cstptr[cstptrix] := cval.valp;
                   if typtr = realptr then
                 gen2(51(*ldc*),2,cstptrix)
                   else
                 gen2(51(*ldc*),5,cstptrix)
                 end;
        varbl: case access of
             drct:   if vlevel<=1 then
                   gen1t(39(*ldo*),dplmt,typtr)
                 else gen2t(54(*lod*),level-vlevel,dplmt,typtr);
             indrct: gen1t(35(*ind*),idplmt,typtr);
             inxd:   error(400)
               end;
        expr:
          end;
          kind := expr
        end
      end (*load*) ;

      procedure store(var fattr: attr);
      begin
    with fattr do
      if typtr <> nil then
        case access of
          drct:   if vlevel <= 1 then gen1t(43(*sro*),dplmt,typtr)
              else gen2t(56(*str*),level-vlevel,dplmt,typtr);
          indrct: if idplmt <> 0 then error(400)
              else gen0t(26(*sto*),typtr);
          inxd:   error(400)
        end
      end (*store*) ;

      procedure loadaddress;
      begin
    with gattr do
      if typtr <> nil then
        begin
          case kind of
        cst:   if string(typtr) then
             if cstptrix >= cstoccmax then error(254)
             else
               begin cstptrix := cstptrix + 1;
                 cstptr[cstptrix] := cval.valp;
                 gen1(38(*lca*),cstptrix)
               end
               else error(400);
        varbl: case access of
             drct:   if vlevel <= 1 then gen1(37(*lao*),dplmt)
                 else gen2(50(*lda*),level-vlevel,dplmt);
             indrct: if idplmt <> 0 then
                   gen1t(34(*inc*),idplmt,nilptr);
             inxd:   error(400)
               end;
        expr:  error(400)
          end;
          kind := varbl; access := indrct; idplmt := 0
        end
      end (*loadaddress*) ;


      procedure genfjp(faddr: integer);
      begin load;
    if gattr.typtr <> nil then
      if gattr.typtr <> boolptr then error(144);
    if prcode then begin putic; writeln(prr,mn[33]:4,' l':8,faddr:4) end;
    ic := ic + 1; mes(33)
      end (*genfjp*) ;

      procedure genujpxjp(fop: oprange; fp2: integer);
      begin
       if prcode then
      begin putic; writeln(prr, mn[fop]:4, ' l':8,fp2:4) end;
    ic := ic + 1; mes(fop)
      end (*genujpxjp*);


      procedure gencupent(fop: oprange; fp1,fp2: integer);
      begin
    if prcode then
      begin putic;
        writeln(prr,mn[fop]:4,fp1:4,'l':4,fp2:4)
      end;
    ic := ic + 1; mes(fop)
      end;


      procedure checkbnds(fsp: stp);
    var lmin,lmax: integer;
      begin
    if fsp <> nil then
      if fsp <> intptr then
        if fsp <> realptr then
          if fsp^.form <= subrange then
        begin
          getbounds(fsp,lmin,lmax);
          gen2t(45(*chk*),lmin,lmax,fsp)
        end
      end (*checkbnds*);


      procedure putlabel(labname: integer);
      begin if prcode then writeln(prr, 'l', labname:4)
      end (*putlabel*);

      procedure statement(fsys: setofsys);
    label 1;
    var lcp: ctp; llp: lbp;

    procedure expression(fsys: setofsys); forward;

    procedure selector(fsys: setofsys; fcp: ctp);
    var lattr: attr; lcp: ctp; lsize: addrrange; lmin,lmax: integer;
    begin
      with fcp^, gattr do
        begin typtr := idtype; kind := varbl;
          case klass of
        vars:
          if vkind = actual then
            begin access := drct; vlevel := vlev;
              dplmt := vaddr
            end
          else
            begin gen2t(54(*lod*),level-vlev,vaddr,nilptr);
              access := indrct; idplmt := 0
            end;
        field:
          with display[disx] do
            if occur = crec then
              begin access := drct; vlevel := clev;
            dplmt := cdspl + fldaddr
              end
            else
              begin
            if level = 1 then gen1t(39(*ldo*),vdspl,nilptr)
            else gen2t(54(*lod*),0,vdspl,nilptr);
            access := indrct; idplmt := fldaddr
              end;
        func:
          if pfdeckind = standard then
            begin error(150); typtr := nil end
          else
            begin
              if pfkind = formal then error(151)
              else
            if (pflev+1<>level)or(fprocp<>fcp) then error(177);
            begin access := drct; vlevel := pflev + 1;
              dplmt := 0   (*impl. relat. addr. of fct. result*)
            end
            end
          end (*case*)
        end (*with*);
      if not (sy in selectsys + fsys) then
        begin error(59); skip(selectsys + fsys) end;
      while sy in selectsys do
        begin
    (*[*) if sy = lbrack then
        begin
          repeat lattr := gattr;
            with lattr do
              if typtr <> nil then
            if typtr^.form <> arrays then
              begin error(138); typtr := nil end;
            loadaddress;
            insymbol; expression(fsys + [comma,rbrack]);
            load;
            if gattr.typtr <> nil then
              if gattr.typtr^.form<>scalar then error(113)
              else if not comptypes(gattr.typtr,intptr) then
                 gen0t(58(*ord*),gattr.typtr);
            if lattr.typtr <> nil then
              with lattr.typtr^ do
            begin
              if comptypes(inxtype,gattr.typtr) then
                begin
                  if inxtype <> nil then
                begin getbounds(inxtype,lmin,lmax);
                  if debug then
                    gen2t(45(*chk*),lmin,lmax,intptr);
                  if lmin>0 then gen1t(31(*dec*),lmin,intptr)
                  else if lmin<0 then
                    gen1t(34(*inc*),-lmin,intptr);
                  (*or simply gen1(31,lmin)*)
                end
                end
              else error(139);
              with gattr do
                begin typtr := aeltype; kind := varbl;
                  access := indrct; idplmt := 0
                end;
              if gattr.typtr <> nil then
                begin
                  lsize := gattr.typtr^.size;
                  align(gattr.typtr,lsize);
                  gen1(36(*ixa*),lsize)
                end
            end
          until sy <> comma;
          if sy = rbrack then insymbol else error(12)
        end (*if sy = lbrack*)
          else
    (*.*)   if sy = period then
          begin
            with gattr do
              begin
            if typtr <> nil then
              if typtr^.form <> records then
                begin error(140); typtr := nil end;
            insymbol;
            if sy = ident then
              begin
                if typtr <> nil then
                  begin searchsection(typtr^.fstfld,lcp);
                if lcp = nil then
                  begin error(152); typtr := nil end
                else
                  with lcp^ do
                    begin typtr := idtype;
                      case access of
                    drct:   dplmt := dplmt + fldaddr;
                    indrct: idplmt := idplmt + fldaddr;
                    inxd:   error(400)
                      end
                    end
                  end;
                insymbol
              end (*sy = ident*)
            else error(2)
              end (*with gattr*)
          end (*if sy = period*)
        else
    (*^*)     begin
            if gattr.typtr <> nil then
              with gattr,typtr^ do
            if form = pointer then
              begin load; typtr := eltype;
                if debug then gen2t(45(*chk*),1,maxaddr,nilptr);
                with gattr do
                  begin kind := varbl; access := indrct;
                idplmt := 0
                  end
              end
            else
              if form = files then typtr := filtype
              else error(141);
            insymbol
          end;
          if not (sy in fsys + selectsys) then
        begin error(6); skip(fsys + selectsys) end
        end (*while*)
    end (*selector*) ;

    procedure call(fsys: setofsys; fcp: ctp);
      var lkey: 1..15;

      procedure variable(fsys: setofsys);
        var lcp: ctp;
      begin
        if sy = ident then
          begin searchid([vars,field],lcp); insymbol end
        else begin error(2); lcp := uvarptr end;
        selector(fsys,lcp)
      end (*variable*) ;

      procedure getputresetrewrite;
      begin variable(fsys + [rparent]); loadaddress;
        if gattr.typtr <> nil then
          if gattr.typtr^.form <> files then error(116);
        if lkey <= 2 then gen1(30(*csp*),lkey(*get,put*))
        else error(399)
      end (*getputresetrewrite*) ;

      procedure read;
        var llev:levrange; laddr:addrrange;
        lsp : stp;
      begin
        llev := 1; laddr := lcaftermarkstack;
        if sy = lparent then
          begin insymbol;
        variable(fsys + [comma,rparent]);
        lsp := gattr.typtr; test := false;
        if lsp <> nil then
          if lsp^.form = files then
            with gattr, lsp^ do
              begin
            if filtype = charptr then
              begin llev := vlevel; laddr := dplmt end
            else error(399);
            if sy = rparent then
              begin if lkey = 5 then error(116);
                test := true
              end
            else
              if sy <> comma then
                begin error(116); skip(fsys + [comma,rparent]) end;
            if sy = comma then
              begin insymbol; variable(fsys + [comma,rparent])
              end
            else test := true
              end;
           if not test then
        repeat loadaddress;
          gen2(50(*lda*),level-llev,laddr);
          if gattr.typtr <> nil then
            if gattr.typtr^.form <= subrange then
              if comptypes(intptr,gattr.typtr) then
            gen1(30(*csp*),3(*rdi*))
              else
            if comptypes(realptr,gattr.typtr) then
              gen1(30(*csp*),4(*rdr*))
            else
              if comptypes(charptr,gattr.typtr) then
                gen1(30(*csp*),5(*rdc*))
              else error(399)
            else error(116);
          test := sy <> comma;
          if not test then
            begin insymbol; variable(fsys + [comma,rparent])
            end
        until test;
        if sy = rparent then insymbol else error(4)
          end
        else if lkey = 5 then error(116);
        if lkey = 11 then
          begin gen2(50(*lda*),level-llev,laddr);
        gen1(30(*csp*),21(*rln*))
          end
      end (*read*) ;

      procedure write;
        var lsp: stp; default : boolean; llkey: 1..15;
        llev:levrange; laddr,len:addrrange;
      begin llkey := lkey;
        llev := 1; laddr := lcaftermarkstack + charmax;
        if sy = lparent then
        begin insymbol;
        expression(fsys + [comma,colon,rparent]);
        lsp := gattr.typtr; test := false;
        if lsp <> nil then
          if lsp^.form = files then
        with gattr, lsp^ do
          begin
            if filtype = charptr then
              begin llev := vlevel; laddr := dplmt end
            else error(399);
            if sy = rparent then
              begin if llkey = 6 then error(116);
            test := true
              end
            else
              if sy <> comma then
            begin error(116); skip(fsys+[comma,rparent]) end;
            if sy = comma then
              begin insymbol; expression(fsys+[comma,colon,rparent])
              end
            else test := true
          end;
       if not test then
        repeat
          lsp := gattr.typtr;
          if lsp <> nil then
        if lsp^.form <= subrange then load else loadaddress;
          if sy = colon then
        begin insymbol; expression(fsys + [comma,colon,rparent]);
          if gattr.typtr <> nil then
            if gattr.typtr <> intptr then error(116);
          load; default := false
        end
          else default := true;
          if sy = colon then
        begin insymbol; expression(fsys + [comma,rparent]);
          if gattr.typtr <> nil then
            if gattr.typtr <> intptr then error(116);
          if lsp <> realptr then error(124);
          load; error(399);
        end
          else
        if lsp = intptr then
          begin if default then gen2(51(*ldc*),1,10);
            gen2(50(*lda*),level-llev,laddr);
            gen1(30(*csp*),6(*wri*))
          end
        else
          if lsp = realptr then
            begin if default then gen2(51(*ldc*),1,20);
              gen2(50(*lda*),level-llev,laddr);
              gen1(30(*csp*),8(*wrr*))
            end
          else
            if lsp = charptr then
              begin if default then gen2(51(*ldc*),1,1);
            gen2(50(*lda*),level-llev,laddr);
            gen1(30(*csp*),9(*wrc*))
              end
            else
              if lsp <> nil then
            begin
              if lsp^.form = scalar then error(399)
              else
                if string(lsp) then
                  begin len := lsp^.size div charmax;
                if default then
                      gen2(51(*ldc*),1,len);
                gen2(51(*ldc*),1,len);
                gen2(50(*lda*),level-llev,laddr);
                gen1(30(*csp*),10(*wrs*))
                  end
                else error(116)
            end;
          test := sy <> comma;
          if not test then
        begin insymbol; expression(fsys + [comma,colon,rparent])
        end
        until test;
        if sy = rparent then insymbol else error(4)
        end
          else if lkey = 6 then error(116);
        if llkey = 12 then (*writeln*)
          begin gen2(50(*lda*),level-llev,laddr);
        gen1(30(*csp*),22(*wln*))
          end
      end (*write*) ;

      procedure pack;
        var lsp,lsp1: stp;
      begin error(399); variable(fsys + [comma,rparent]);
        lsp := nil; lsp1 := nil;
        if gattr.typtr <> nil then
          with gattr.typtr^ do
        if form = arrays then
          begin lsp := inxtype; lsp1 := aeltype end
        else error(116);
        if sy = comma then insymbol else error(20);
        expression(fsys + [comma,rparent]);
        if gattr.typtr <> nil then
          if gattr.typtr^.form <> scalar then error(116)
          else
        if not comptypes(lsp,gattr.typtr) then error(116);
        if sy = comma then insymbol else error(20);
        variable(fsys + [rparent]);
        if gattr.typtr <> nil then
          with gattr.typtr^ do
        if form = arrays then
          begin
            if not comptypes(aeltype,lsp1)
              or not comptypes(inxtype,lsp) then
              error(116)
          end
        else error(116)
      end (*pack*) ;

      procedure unpack;
        var lsp,lsp1: stp;
      begin error(399); variable(fsys + [comma,rparent]);
        lsp := nil; lsp1 := nil;
        if gattr.typtr <> nil then
          with gattr.typtr^ do
        if form = arrays then
          begin lsp := inxtype; lsp1 := aeltype end
        else error(116);
        if sy = comma then insymbol else error(20);
        variable(fsys + [comma,rparent]);
        if gattr.typtr <> nil then
          with gattr.typtr^ do
        if form = arrays then
          begin
            if not comptypes(aeltype,lsp1)
              or not comptypes(inxtype,lsp) then
              error(116)
          end
        else error(116);
        if sy = comma then insymbol else error(20);
        expression(fsys + [rparent]);
        if gattr.typtr <> nil then
          if gattr.typtr^.form <> scalar then error(116)
          else
        if not comptypes(lsp,gattr.typtr) then error(116);
      end (*unpack*) ;

      procedure new;
        label 1;
        var lsp,lsp1: stp; varts: integer;
        lsize: addrrange; lval: valu;
      begin variable(fsys + [comma,rparent]); loadaddress;
        lsp := nil; varts := 0; lsize := 0;
        if gattr.typtr <> nil then
          with gattr.typtr^ do
        if form = pointer then
          begin
            if eltype <> nil then
              begin lsize := eltype^.size;
            if eltype^.form = records then lsp := eltype^.recvar
              end
          end
        else error(116);
        while sy = comma do
          begin insymbol;constant(fsys + [comma,rparent],lsp1,lval);
        varts := varts + 1;
        (*check to insert here: is constant in tagfieldtype range*)
        if lsp = nil then error(158)
        else
          if lsp^.form <> tagfld then error(162)
          else
            if lsp^.tagfieldp <> nil then
              if string(lsp1) or (lsp1 = realptr) then error(159)
              else
            if comptypes(lsp^.tagfieldp^.idtype,lsp1) then
              begin
                lsp1 := lsp^.fstvar;
                while lsp1 <> nil do
                  with lsp1^ do
                if varval.ival = lval.ival then
                  begin lsize := size; lsp := subvar;
                    goto 1
                  end
                else lsp1 := nxtvar;
                lsize := lsp^.size; lsp := nil;
              end
            else error(116);
      1:  end (*while*) ;
        gen2(51(*ldc*),1,lsize);
        gen1(30(*csp*),12(*new*));
      end (*new*) ;

      procedure mark;
      begin variable(fsys+[rparent]);
         if gattr.typtr <> nil then
           if gattr.typtr^.form = pointer then
         begin loadaddress; gen1(30(*csp*),23(*sav*)) end
           else error(116)
      end(*mark*);

      procedure release;
      begin variable(fsys+[rparent]);
        if gattr.typtr <> nil then
           if gattr.typtr^.form = pointer then
              begin load; gen1(30(*csp*),13(*rst*)) end
           else error(116)
      end (*release*);



      procedure abs;
      begin
        if gattr.typtr <> nil then
          if gattr.typtr = intptr then gen0(0(*abi*))
          else
        if gattr.typtr = realptr then gen0(1(*abr*))
        else begin error(125); gattr.typtr := intptr end
      end (*abs*) ;

      procedure sqr;
      begin
        if gattr.typtr <> nil then
          if gattr.typtr = intptr then gen0(24(*sqi*))
          else
        if gattr.typtr = realptr then gen0(25(*sqr*))
        else begin error(125); gattr.typtr := intptr end
      end (*sqr*) ;

      procedure trunc;
      begin
        if gattr.typtr <> nil then
          if gattr.typtr <> realptr then error(125);
        gen0(27(*trc*));
        gattr.typtr := intptr
      end (*trunc*) ;

      procedure odd;
      begin
        if gattr.typtr <> nil then
          if gattr.typtr <> intptr then error(125);
        gen0(20(*odd*));
        gattr.typtr := boolptr
      end (*odd*) ;

      procedure ord;
      begin
        if gattr.typtr <> nil then
          if gattr.typtr^.form >= power then error(125);
        gen0t(58(*ord*),gattr.typtr);
        gattr.typtr := intptr
      end (*ord*) ;

      procedure chr;
      begin
        if gattr.typtr <> nil then
          if gattr.typtr <> intptr then error(125);
        gen0(59(*chr*));
        gattr.typtr := charptr
      end (*chr*) ;

      procedure predsucc;
      begin
        if gattr.typtr <> nil then
          if gattr.typtr^.form <> scalar then error(125);
        if lkey = 7 then gen1t(31(*dec*),1,gattr.typtr)
        else gen1t(34(*inc*),1,gattr.typtr)
      end (*predsucc*) ;

      procedure eof;
      begin
        if sy = lparent then
          begin insymbol; variable(fsys + [rparent]);
        if sy = rparent then insymbol else error(4)
          end
        else
          with gattr do
        begin typtr := textptr; kind := varbl; access := drct;
          vlevel := 1; dplmt := lcaftermarkstack
        end;
        loadaddress;
        if gattr.typtr <> nil then
          if gattr.typtr^.form <> files then error(125);
        if lkey = 9 then gen0(8(*eof*)) else gen1(30(*csp*),14(*eln*));
          gattr.typtr := boolptr
      end (*eof*) ;



      procedure callnonstandard;
        var nxt,lcp: ctp; lsp: stp; lkind: idkind; lb: boolean;
        locpar, llc: addrrange;
      begin locpar := 0;
        with fcp^ do
          begin nxt := next; lkind := pfkind;
        if not externl then gen1(41(*mst*),level-pflev)
          end;
        if sy = lparent then
          begin llc := lc;
        repeat lb := false; (*decide whether proc/func must be passed*)
          if lkind = actual then
            begin
              if nxt = nil then error(126)
              else lb := nxt^.klass in [proc,func]
            end else error(399);
          (*For formal proc/func, lb is false and expression
           will be called, which will always interpret a proc/func id
           at its beginning as a call rather than a parameter passing.
           In this implementation, parameter procedures/functions
           are therefore not allowed to have procedure/function
           parameters*)
          insymbol;
          if lb then   (*pass function or procedure*)
            begin error(399);
              if sy <> ident then
            begin error(2); skip(fsys + [comma,rparent]) end
              else
            begin
              if nxt^.klass = proc then searchid([proc],lcp)
              else
                begin searchid([func],lcp);
                  if not comptypes(lcp^.idtype,nxt^.idtype) then
                error(128)
                end;
              insymbol;
              if not (sy in fsys + [comma,rparent]) then
                begin error(6); skip(fsys + [comma,rparent]) end
            end
            end (*if lb*)
          else
            begin expression(fsys + [comma,rparent]);
              if gattr.typtr <> nil then
            if lkind = actual then
              begin
                if nxt <> nil then
                  begin lsp := nxt^.idtype;
                if lsp <> nil then
                  begin
                    if (nxt^.vkind = actual) then
                      if lsp^.form <= power then
                    begin load;
                      if debug then checkbnds(lsp);
                      if comptypes(realptr,lsp)
                         and (gattr.typtr = intptr) then
                        begin gen0(10(*flt*));
                          gattr.typtr := realptr
                        end;
                      locpar := locpar+lsp^.size;
                      align(parmptr,locpar);
                    end
                      else
                    begin
                      loadaddress;
                      locpar := locpar+ptrsize;
                      align(parmptr,locpar)
                    end
                    else
                      if gattr.kind = varbl then
                    begin loadaddress;
                      locpar := locpar+ptrsize;
                      align(parmptr,locpar);
                    end
                      else error(154);
                    if not comptypes(lsp,gattr.typtr) then
                      error(142)
                  end
                  end
              end
              else (*lkind = formal*)
            begin (*pass formal param*)
            end
            end;
          if (lkind = actual) and (nxt <> nil) then nxt := nxt^.next
        until sy <> comma;
        lc := llc;
        if sy = rparent then insymbol else error(4)
          end (*if lparent*);
        if lkind = actual then
          begin if nxt <> nil then error(126);
        with fcp^ do
          begin
            if externl then gen1(30(*csp*),pfname)
            else gencupent(46(*cup*),locpar,pfname);
          end
          end;
        gattr.typtr := fcp^.idtype
      end (*callnonstandard*) ;

    begin (*call*)
      if fcp^.pfdeckind = standard then
        begin lkey := fcp^.key;
          if fcp^.klass = proc then
           begin
        if not(lkey in [5,6,11,12]) then
          if sy = lparent then insymbol else error(9);
        case lkey of
          1,2,
          3,4:  getputresetrewrite;
          5,11: read;
          6,12: write;
          7:    pack;
          8:    unpack;
          9:    new;
          10:   release;
          13:   mark
        end;
        if not(lkey in [5,6,11,12]) then
          if sy = rparent then insymbol else error(4)
           end
          else
        begin
          if lkey <= 8 then
            begin
              if sy = lparent then insymbol else error(9);
              expression(fsys+[rparent]); load
            end;
          case lkey of
            1:    abs;
            2:    sqr;
            3:    trunc;
            4:    odd;
            5:    ord;
            6:    chr;
            7,8:  predsucc;
            9,10: eof
          end;
          if lkey <= 8 then
            if sy = rparent then insymbol else error(4)
        end;
        end (*standard procedures and functions*)
      else callnonstandard
    end (*call*) ;

    procedure expression;
      var lattr: attr; lop: operator; typind: char; lsize: addrrange;

      procedure simpleexpression(fsys: setofsys);
        var lattr: attr; lop: operator; signed: boolean;

        procedure term(fsys: setofsys);
          var lattr: attr; lop: operator;

          procedure factor(fsys: setofsys);
        var lcp: ctp; lvp: csp; varpart: boolean;
            cstpart: setty; lsp: stp;
          begin
        if not (sy in facbegsys) then
          begin error(58); skip(fsys + facbegsys);
            gattr.typtr := nil
          end;
        while sy in facbegsys do
          begin
            case sy of
          (*id*)    ident:
            begin searchid([konst,vars,field,func],lcp);
              insymbol;
              if lcp^.klass = func then
                begin call(fsys,lcp);
                  with gattr do
                begin kind := expr;
                  if typtr <> nil then
                    if typtr^.form=subrange then
                      typtr := typtr^.rangetype
                end
                end
              else
                if lcp^.klass = konst then
                  with gattr, lcp^ do
                begin typtr := idtype; kind := cst;
                  cval := values
                end
                else
                  begin selector(fsys,lcp);
                if gattr.typtr<>nil then(*elim.subr.types to*)
                  with gattr,typtr^ do(*simplify later tests*)
                    if form = subrange then
                      typtr := rangetype
                  end
            end;
          (*cst*)   intconst:
            begin
              with gattr do
                begin typtr := intptr; kind := cst;
                  cval := val
                end;
              insymbol
            end;
              realconst:
            begin
              with gattr do
                begin typtr := realptr; kind := cst;
                  cval := val
                end;
              insymbol
            end;
              stringconst:
            begin
              with gattr do
                begin
                  if lgth = 1 then typtr := charptr
                  else
                begin new(lsp,arrays);
                  with lsp^ do
                    begin aeltype := charptr; form:=arrays;
                      inxtype := nil; size := lgth*charsize
                    end;
                  typtr := lsp
                end;
                  kind := cst; cval := val
                end;
              insymbol
            end;
          (* ( *)   lparent:
            begin insymbol; expression(fsys + [rparent]);
              if sy = rparent then insymbol else error(4)
            end;
          (*not*)   notsy:
            begin insymbol; factor(fsys);
              load; gen0(19(*not*));
              if gattr.typtr <> nil then
                if gattr.typtr <> boolptr then
                  begin error(135); gattr.typtr := nil end;
            end;
          (*[*)     lbrack:
            begin insymbol; cstpart := [ ]; varpart := false;
              new(lsp,power);
              with lsp^ do
                begin elset:=nil;size:=setsize;form:=power end;
              if sy = rbrack then
                begin
                  with gattr do
                begin typtr := lsp; kind := cst end;
                  insymbol
                end
              else
                begin
                  repeat expression(fsys + [comma,rbrack]);
                if gattr.typtr <> nil then
                  if gattr.typtr^.form <> scalar then
                    begin error(136); gattr.typtr := nil end
                  else
                    if comptypes(lsp^.elset,gattr.typtr) then
                      begin
                    if gattr.kind = cst then
                      if (gattr.cval.ival < setlow) or
                        (gattr.cval.ival > sethigh) then
                        error(304)
                      else
                        cstpart := cstpart+[gattr.cval.ival]
                    else
                      begin load;
                        if not comptypes(gattr.typtr,intptr)
                        then gen0t(58(*ord*),gattr.typtr);
                        gen0(23(*sgs*));
                        if varpart then gen0(28(*uni*))
                        else varpart := true
                      end;
                    lsp^.elset := gattr.typtr;
                    gattr.typtr := lsp
                      end
                    else error(137);
                test := sy <> comma;
                if not test then insymbol
                  until test;
                  if sy = rbrack then insymbol else error(12)
                end;
              if varpart then
                begin
                  if cstpart <> [ ] then
                begin new(lvp,pset); lvp^.pval := cstpart;
                  lvp^.cclass := pset;
                  if cstptrix = cstoccmax then error(254)
                  else
                    begin cstptrix := cstptrix + 1;
                      cstptr[cstptrix] := lvp;
                      gen2(51(*ldc*),5,cstptrix);
                      gen0(28(*uni*)); gattr.kind := expr
                    end
                end
                end
              else
                begin new(lvp,pset); lvp^.pval := cstpart;
                  lvp^.cclass := pset;
                  gattr.cval.valp := lvp
                end
            end
            end (*case*) ;
            if not (sy in fsys) then
              begin error(6); skip(fsys + facbegsys) end
          end (*while*)
          end (*factor*) ;

        begin (*term*)
          factor(fsys + [mulop]);
          while sy = mulop do
        begin load; lattr := gattr; lop := op;
          insymbol; factor(fsys + [mulop]); load;
          if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
            case lop of
        (***)     mul:  if (lattr.typtr=intptr)and(gattr.typtr=intptr)
                then gen0(15(*mpi*))
                else
                  begin
                if lattr.typtr = intptr then
                  begin gen0(9(*flo*));
                    lattr.typtr := realptr
                  end
                else
                  if gattr.typtr = intptr then
                    begin gen0(10(*flt*));
                      gattr.typtr := realptr
                    end;
                if (lattr.typtr = realptr)
                  and(gattr.typtr=realptr)then gen0(16(*mpr*))
                else
                  if(lattr.typtr^.form=power)
                    and comptypes(lattr.typtr,gattr.typtr)then
                    gen0(12(*int*))
                  else begin error(134); gattr.typtr:=nil end
                  end;
        (* / *)   rdiv: begin
                  if gattr.typtr = intptr then
                begin gen0(10(*flt*));
                  gattr.typtr := realptr
                end;
                  if lattr.typtr = intptr then
                begin gen0(9(*flo*));
                  lattr.typtr := realptr
                end;
                  if (lattr.typtr = realptr)
                and (gattr.typtr=realptr)then gen0(7(*dvr*))
                  else begin error(134); gattr.typtr := nil end
                end;
        (*div*)   idiv: if (lattr.typtr = intptr)
                  and (gattr.typtr = intptr) then gen0(6(*dvi*))
                else begin error(134); gattr.typtr := nil end;
        (*mod*)   imod: if (lattr.typtr = intptr)
                  and (gattr.typtr = intptr) then gen0(14(*mod*))
                else begin error(134); gattr.typtr := nil end;
        (*and*)   andop:if (lattr.typtr = boolptr)
                  and (gattr.typtr = boolptr) then gen0(4(*and*))
                else begin error(134); gattr.typtr := nil end
            end (*case*)
          else gattr.typtr := nil
        end (*while*)
        end (*term*) ;

      begin (*simpleexpression*)
        signed := false;
        if (sy = addop) and (op in [plus,minus]) then
          begin signed := op = minus; insymbol end;
        term(fsys + [addop]);
        if signed then
          begin load;
        if gattr.typtr = intptr then gen0(17(*ngi*))
        else
          if gattr.typtr = realptr then gen0(18(*ngr*))
          else begin error(134); gattr.typtr := nil end
          end;
        while sy = addop do
          begin load; lattr := gattr; lop := op;
        insymbol; term(fsys + [addop]); load;
        if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
          case lop of
      (*+*)       plus:
              if (lattr.typtr = intptr)and(gattr.typtr = intptr) then
            gen0(2(*adi*))
              else
            begin
              if lattr.typtr = intptr then
                begin gen0(9(*flo*));
                  lattr.typtr := realptr
                end
              else
                if gattr.typtr = intptr then
                  begin gen0(10(*flt*));
                gattr.typtr := realptr
                  end;
              if (lattr.typtr = realptr)and(gattr.typtr = realptr)
                then gen0(3(*adr*))
              else if(lattr.typtr^.form=power)
                 and comptypes(lattr.typtr,gattr.typtr) then
                 gen0(28(*uni*))
                   else begin error(134); gattr.typtr:=nil end
            end;
      (*-*)       minus:
              if (lattr.typtr = intptr)and(gattr.typtr = intptr) then
            gen0(21(*sbi*))
              else
            begin
              if lattr.typtr = intptr then
                begin gen0(9(*flo*));
                  lattr.typtr := realptr
                end
              else
                if gattr.typtr = intptr then
                  begin gen0(10(*flt*));
                gattr.typtr := realptr
                  end;
              if (lattr.typtr = realptr)and(gattr.typtr = realptr)
                then gen0(22(*sbr*))
              else
                if (lattr.typtr^.form = power)
                  and comptypes(lattr.typtr,gattr.typtr) then
                  gen0(5(*dif*))
                else begin error(134); gattr.typtr := nil end
            end;
      (*or*)      orop:
              if(lattr.typtr=boolptr)and(gattr.typtr=boolptr)then
            gen0(13(*ior*))
              else begin error(134); gattr.typtr := nil end
          end (*case*)
        else gattr.typtr := nil
          end (*while*)
      end (*simpleexpression*) ;

    begin (*expression*)
      simpleexpression(fsys + [relop]);
      if sy = relop then
        begin
          if gattr.typtr <> nil then
        if gattr.typtr^.form <= power then load
        else loadaddress;
          lattr := gattr; lop := op;
          if lop = inop then
        if not comptypes(gattr.typtr,intptr) then
          gen0t(58(*ord*),gattr.typtr);
          insymbol; simpleexpression(fsys);
          if gattr.typtr <> nil then
        if gattr.typtr^.form <= power then load
        else loadaddress;
          if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
        if lop = inop then
          if gattr.typtr^.form = power then
            if comptypes(lattr.typtr,gattr.typtr^.elset) then
              gen0(11(*inn*))
            else begin error(129); gattr.typtr := nil end
          else begin error(130); gattr.typtr := nil end
        else
          begin
            if lattr.typtr <> gattr.typtr then
              if lattr.typtr = intptr then
            begin gen0(9(*flo*));
              lattr.typtr := realptr
            end
              else
            if gattr.typtr = intptr then
              begin gen0(10(*flt*));
                gattr.typtr := realptr
              end;
            if comptypes(lattr.typtr,gattr.typtr) then
              begin lsize := lattr.typtr^.size;
            case lattr.typtr^.form of
              scalar:
                if lattr.typtr = realptr then typind := 'r'
                else
                  if lattr.typtr = boolptr then typind := 'b'
                  else
                if lattr.typtr = charptr then typind := 'c'
                else typind := 'i';
              pointer:
                begin
                  if lop in [ltop,leop,gtop,geop] then error(131);
                  typind := 'a'
                end;
              power:
                begin if lop in [ltop,gtop] then error(132);
                  typind := 's'
                end;
              arrays:
                begin
                  if not string(lattr.typtr)
                then error(134);
                  typind := 'm'
                end;
              records:
                begin
                  error(134);
                  typind := 'm'
                end;
              files:
                begin error(133); typind := 'f' end
            end;
            case lop of
              ltop: gen2(53(*les*),ord(typind),lsize);
              leop: gen2(52(*leq*),ord(typind),lsize);
              gtop: gen2(49(*grt*),ord(typind),lsize);
              geop: gen2(48(*geq*),ord(typind),lsize);
              neop: gen2(55(*neq*),ord(typind),lsize);
              eqop: gen2(47(*equ*),ord(typind),lsize)
            end
              end
            else error(129)
          end;
          gattr.typtr := boolptr; gattr.kind := expr
        end (*sy = relop*)
    end (*expression*) ;

    procedure assignment(fcp: ctp);
      var lattr: attr;
    begin selector(fsys + [becomes],fcp);
      if sy = becomes then
        begin
          if gattr.typtr <> nil then
        if (gattr.access<>drct) or (gattr.typtr^.form>power) then
          loadaddress;
          lattr := gattr;
          insymbol; expression(fsys);
          if gattr.typtr <> nil then
        if gattr.typtr^.form <= power then load
        else loadaddress;
          if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
        begin
          if comptypes(realptr,lattr.typtr)and(gattr.typtr=intptr)then
            begin gen0(10(*flt*));
              gattr.typtr := realptr
            end;
          if comptypes(lattr.typtr,gattr.typtr) then
            case lattr.typtr^.form of
              scalar,
              subrange: begin
                  if debug then checkbnds(lattr.typtr);
                  store(lattr)
                end;
              pointer: begin
                 if debug then
                   gen2t(45(*chk*),0,maxaddr,nilptr);
                 store(lattr)
                   end;
              power:   store(lattr);
              arrays,
              records: gen1(40(*mov*),lattr.typtr^.size);
              files: error(146)
            end
          else error(129)
        end
        end (*sy = becomes*)
      else error(51)
    end (*assignment*) ;

    procedure gotostatement;
      var llp: lbp; found: boolean; ttop,ttop1: disprange;
    begin
      if sy = intconst then
        begin
          found := false;
          ttop := top;
          while display[ttop].occur <> blck do ttop := ttop - 1;
          ttop1 := ttop;
          repeat
        llp := display[ttop].flabel;
        while (llp <> nil) and not found do
          with llp^ do
            if labval = val.ival then
              begin found := true;
            if ttop = ttop1 then
              genujpxjp(57(*ujp*),labname)
            else (*goto leads out of procedure*) error(399)
              end
            else llp := nextlab;
        ttop := ttop - 1
          until found or (ttop = 0);
          if not found then error(167);
          insymbol
        end
      else error(15)
    end (*gotostatement*) ;

    procedure compoundstatement;
    begin
      repeat
        repeat statement(fsys + [semicolon,endsy])
        until not (sy in statbegsys);
        test := sy <> semicolon;
        if not test then insymbol
      until test;
      if sy = endsy then insymbol else error(13)
    end (*compoundstatemenet*) ;

    procedure ifstatement;
      var lcix1,lcix2: integer;
    begin expression(fsys + [thensy]);
      genlabel(lcix1); genfjp(lcix1);
      if sy = thensy then insymbol else error(52);
      statement(fsys + [elsesy]);
      if sy = elsesy then
        begin genlabel(lcix2); genujpxjp(57(*ujp*),lcix2);
          putlabel(lcix1);
          insymbol; statement(fsys);
          putlabel(lcix2)
        end
      else putlabel(lcix1)
    end (*ifstatement*) ;

    procedure casestatement;
      label 1;
      type cip = ^caseinfo;
           caseinfo = packed
              record next: cip;
                csstart: integer;
                cslab: integer
              end;
      var lsp,lsp1: stp; fstptr,lpt1,lpt2,lpt3: cip; lval: valu;
          laddr, lcix, lcix1, lmin, lmax: integer;
    begin expression(fsys + [ofsy,comma,colon]);
      load; genlabel(lcix);
      lsp := gattr.typtr;
      if lsp <> nil then
        if (lsp^.form <> scalar) or (lsp = realptr) then
          begin error(144); lsp := nil end
        else if not comptypes(lsp,intptr) then gen0t(58(*ord*),lsp);
      genujpxjp(57(*ujp*),lcix);
      if sy = ofsy then insymbol else error(8);
      fstptr := nil; genlabel(laddr);
      repeat
        lpt3 := nil; genlabel(lcix1);
        if not(sy in [semicolon,endsy]) then
          begin
        repeat constant(fsys + [comma,colon],lsp1,lval);
          if lsp <> nil then
            if comptypes(lsp,lsp1) then
              begin lpt1 := fstptr; lpt2 := nil;
            while lpt1 <> nil do
              with lpt1^ do
                begin
                  if cslab <= lval.ival then
                begin if cslab = lval.ival then error(156);
                  goto 1
                end;
                  lpt2 := lpt1; lpt1 := next
                end;
        1:      new(lpt3);
            with lpt3^ do
              begin next := lpt1; cslab := lval.ival;
                csstart := lcix1
              end;
            if lpt2 = nil then fstptr := lpt3
            else lpt2^.next := lpt3
              end
            else error(147);
          test := sy <> comma;
          if not test then insymbol
        until test;
        if sy = colon then insymbol else error(5);
        putlabel(lcix1);
        repeat statement(fsys + [semicolon])
        until not (sy in statbegsys);
        if lpt3 <> nil then
          genujpxjp(57(*ujp*),laddr);
          end;
        test := sy <> semicolon;
        if not test then insymbol
      until test;
      putlabel(lcix);
      if fstptr <> nil then
        begin lmax := fstptr^.cslab;
          (*reverse pointers*)
          lpt1 := fstptr; fstptr := nil;
          repeat lpt2 := lpt1^.next; lpt1^.next := fstptr;
        fstptr := lpt1; lpt1 := lpt2
          until lpt1 = nil;
          lmin := fstptr^.cslab;
          if lmax - lmin < cixmax then
        begin
          gen2t(45(*chk*),lmin,lmax,intptr);
          gen2(51(*ldc*),1,lmin); gen0(21(*sbi*)); genlabel(lcix);
          genujpxjp(44(*xjp*),lcix); putlabel(lcix);
          repeat
            with fstptr^ do
              begin
            while cslab > lmin do
               begin gen0(60(*ujc error*));
                 lmin := lmin+1
               end;
            genujpxjp(57(*ujp*),csstart);
            fstptr := next; lmin := lmin + 1
              end
          until fstptr = nil;
          putlabel(laddr)
        end
          else error(157)
        end;
        if sy = endsy then insymbol else error(13)
    end (*casestatement*) ;

    procedure repeatstatement;
      var laddr: integer;
    begin genlabel(laddr); putlabel(laddr);
      repeat statement(fsys + [semicolon,untilsy]);
        if sy in statbegsys then error(14)
      until not(sy in statbegsys);
      while sy = semicolon do
        begin insymbol;
          repeat statement(fsys + [semicolon,untilsy]);
        if sy in statbegsys then error(14)
          until not (sy in statbegsys);
        end;
      if sy = untilsy then
        begin insymbol; expression(fsys); genfjp(laddr)
        end
      else error(53)
    end (*repeatstatement*) ;

    procedure whilestatement;
      var laddr, lcix: integer;
    begin genlabel(laddr); putlabel(laddr);
      expression(fsys + [dosy]); genlabel(lcix); genfjp(lcix);
      if sy = dosy then insymbol else error(54);
      statement(fsys); genujpxjp(57(*ujp*),laddr); putlabel(lcix)
    end (*whilestatement*) ;

    procedure forstatement;
      var lattr: attr;  lsy: symbol;
          lcix, laddr: integer;
            llc: addrrange;
    begin llc := lc;
      with lattr do
        begin typtr := nil; kind := varbl;
          access := drct; vlevel := level; dplmt := 0
        end;
      if sy = ident then
        begin searchid([vars],lcp);
          with lcp^, lattr do
        begin typtr := idtype; kind := varbl;
          if vkind = actual then
            begin access := drct; vlevel := vlev;
              dplmt := vaddr
            end
          else begin error(155); typtr := nil end
        end;
          if lattr.typtr <> nil then
        if (lattr.typtr^.form > subrange)
           or comptypes(realptr,lattr.typtr) then
          begin error(143); lattr.typtr := nil end;
          insymbol
        end
      else
        begin error(2); skip(fsys + [becomes,tosy,downtosy,dosy]) end;
      if sy = becomes then
        begin insymbol; expression(fsys + [tosy,downtosy,dosy]);
          if gattr.typtr <> nil then
          if gattr.typtr^.form <> scalar then error(144)
          else
            if comptypes(lattr.typtr,gattr.typtr) then
              begin load; store(lattr) end
            else error(145)
        end
      else
        begin error(51); skip(fsys + [tosy,downtosy,dosy]) end;
      if sy in [tosy,downtosy] then
        begin lsy := sy; insymbol; expression(fsys + [dosy]);
          if gattr.typtr <> nil then
          if gattr.typtr^.form <> scalar then error(144)
        else
          if comptypes(lattr.typtr,gattr.typtr) then
            begin load;
              if not comptypes(lattr.typtr,intptr) then
            gen0t(58(*ord*),gattr.typtr);
              align(intptr,lc);
              gen2t(56(*str*),0,lc,intptr);
              genlabel(laddr); putlabel(laddr);
              gattr := lattr; load;
              if not comptypes(gattr.typtr,intptr) then
            gen0t(58(*ord*),gattr.typtr);
              gen2t(54(*lod*),0,lc,intptr);
              lc := lc + intsize;
              if lc > lcmax then lcmax := lc;
              if lsy = tosy then gen2(52(*leq*),ord('i'),1)
              else gen2(48(*geq*),ord('i'),1);
            end
          else error(145)
        end
      else begin error(55); skip(fsys + [dosy]) end;
      genlabel(lcix); genujpxjp(33(*fjp*),lcix);
      if sy = dosy then insymbol else error(54);
      statement(fsys);
      gattr := lattr; load;
      if lsy=tosy then gen1t(34(*inc*),1,gattr.typtr)
      else  gen1t(31(*dec*),1,gattr.typtr);
      store(lattr); genujpxjp(57(*ujp*),laddr); putlabel(lcix);
      lc := llc;
    end (*forstatement*) ;


    procedure withstatement;
      var lcp: ctp; lcnt1: disprange; llc: addrrange;
    begin lcnt1 := 0; llc := lc;
      repeat
        if sy = ident then
          begin searchid([vars,field],lcp); insymbol end
        else begin error(2); lcp := uvarptr end;
        selector(fsys + [comma,dosy],lcp);
        if gattr.typtr <> nil then
          if gattr.typtr^.form = records then
        if top < displimit then
          begin top := top + 1; lcnt1 := lcnt1 + 1;
            with display[top] do
              begin fname := gattr.typtr^.fstfld;
            flabel := nil
              end;
            if gattr.access = drct then
              with display[top] do
            begin occur := crec; clev := gattr.vlevel;
              cdspl := gattr.dplmt
            end
            else
              begin loadaddress;
            align(nilptr,lc);
            gen2t(56(*str*),0,lc,nilptr);
            with display[top] do
              begin occur := vrec; vdspl := lc end;
            lc := lc+ptrsize;
            if lc > lcmax then lcmax := lc
              end
          end
        else error(250)
          else error(140);
        test := sy <> comma;
        if not test then insymbol
      until test;
      if sy = dosy then insymbol else error(54);
      statement(fsys);
      top := top-lcnt1; lc := llc;
    end (*withstatement*) ;

      begin (*statement*)
    if sy = intconst then (*label*)
      begin llp := display[level].flabel;
        while llp <> nil do
          with llp^ do
        if labval = val.ival then
          begin if defined then error(165);
            putlabel(labname); defined := true;
            goto 1
          end
        else llp := nextlab;
        error(167);
      1:    insymbol;
        if sy = colon then insymbol else error(5)
      end;
    if not (sy in fsys + [ident]) then
      begin error(6); skip(fsys) end;
    if sy in statbegsys + [ident] then
      begin
        case sy of
          ident:    begin searchid([vars,field,func,proc],lcp); insymbol;
              if lcp^.klass = proc then call(fsys,lcp)
              else assignment(lcp)
            end;
          beginsy:  begin insymbol; compoundstatement end;
          gotosy:   begin insymbol; gotostatement end;
          ifsy:     begin insymbol; ifstatement end;
          casesy:   begin insymbol; casestatement end;
          whilesy:  begin insymbol; whilestatement end;
          repeatsy: begin insymbol; repeatstatement end;
          forsy:    begin insymbol; forstatement end;
          withsy:   begin insymbol; withstatement end
        end;
        if not (sy in [semicolon,endsy,elsesy,untilsy]) then
          begin error(6); skip(fsys) end
      end
      end (*statement*) ;

    begin (*body*)
      if fprocp <> nil then entname := fprocp^.pfname
      else genlabel(entname);
      cstptrix := 0; topnew := lcaftermarkstack; topmax := lcaftermarkstack;
      putlabel(entname); genlabel(segsize); genlabel(stacktop);
      gencupent(32(*ent1*),1,segsize); gencupent(32(*ent2*),2,stacktop);
      if fprocp <> nil then (*copy multiple values into local cells*)
    begin llc1 := lcaftermarkstack;
      lcp := fprocp^.next;
      while lcp <> nil do
        with lcp^ do
          begin
        align(parmptr,llc1);
        if klass = vars then
          if idtype <> nil then
            if idtype^.form > power then
              begin
            if vkind = actual then
              begin
                gen2(50(*lda*),0,vaddr);
                gen2t(54(*lod*),0,llc1,nilptr);
                gen1(40(*mov*),idtype^.size);
              end;
            llc1 := llc1 + ptrsize
              end
            else llc1 := llc1 + idtype^.size;
        lcp := lcp^.next;
          end;
    end;
      lcmax := lc;
      repeat
    repeat statement(fsys + [semicolon,endsy])
    until not (sy in statbegsys);
    test := sy <> semicolon;
    if not test then insymbol
      until test;
      if sy = endsy then insymbol else error(13);
      llp := display[top].flabel; (*test for undefined labels*)
      while llp <> nil do
    with llp^ do
      begin
        if not defined then
          begin error(168);
        writeln(output); writeln(output,' label ',labval);
        write(output,' ':chcnt+16)
          end;
        llp := nextlab
      end;
      if fprocp <> nil then
    begin
      if fprocp^.idtype = nil then gen1(42(*ret*),ord('p'))
      else gen0t(42(*ret*),fprocp^.idtype);
      align(parmptr,lcmax);
      if prcode then
        begin writeln(prr,'l',segsize:4,'=',lcmax);
          writeln(prr,'l',stacktop:4,'=',topmax)
        end
    end
      else
    begin gen1(42(*ret*),ord('p'));
      align(parmptr,lcmax);
      if prcode then
        begin writeln(prr,'l',segsize:4,'=',lcmax);
          writeln(prr,'l',stacktop:4,'=',topmax);
          writeln(prr,'q')
        end;
      ic := 0;
      (*generate call of main program; note that this call must be loaded
        at absolute address zero*)
      gen1(41(*mst*),0); gencupent(46(*cup*),0,entname); gen0(29(*stp*));
      if prcode then
        writeln(prr,'q');
      saveid := id;
      while fextfilep <> nil do
        begin
          with fextfilep^ do
        if not ((filename = 'input   ') or (filename = 'output  ') or
            (filename = 'prd     ') or (filename = 'prr     '))
        then begin id := filename;
               searchid([vars],llcp);
               if llcp^.idtype<>nil then
             if llcp^.idtype^.form<>files then
               begin writeln(output);
                 writeln(output,' ':8,'undeclared ','external ',
                   'file',fextfilep^.filename:8);
                 write(output,' ':chcnt+16)
               end
             end;
        fextfilep := fextfilep^.nextfile
        end;
      id := saveid;
      if prtables then
        begin writeln(output); printtables(true)
        end
    end;
    end (*body*) ;

  begin (*block*)
    dp := true;
    repeat
      if sy = labelsy then
    begin insymbol; labeldeclaration end;
      if sy = constsy then
    begin insymbol; constdeclaration end;
      if sy = typesy then
    begin insymbol; typedeclaration end;
      if sy = varsy then
    begin insymbol; vardeclaration end;
      while sy in [procsy,funcsy] do
    begin lsy := sy; insymbol; procdeclaration(lsy) end;
      if sy <> beginsy then
    begin error(18); skip(fsys) end
    until (sy in statbegsys) or eof(input);
    dp := false;
    if sy = beginsy then insymbol else error(17);
    repeat body(fsys + [casesy]);
      if sy <> fsy then
    begin error(6); skip(fsys) end
    until ((sy = fsy) or (sy in blockbegsys)) or eof(input);
  end (*block*) ;

  procedure programme(fsys:setofsys);
    var extfp:extfilep;
  begin
    if sy = progsy then
      begin insymbol; if sy <> ident then error(2); insymbol;
    if not (sy in [lparent,semicolon]) then error(14);
    if sy = lparent  then
      begin
        repeat insymbol;
          if sy = ident then
        begin new(extfp);
          with extfp^ do
            begin filename := id; nextfile := fextfilep end;
          fextfilep := extfp;
          insymbol;
          if not ( sy in [comma,rparent] ) then error(20)
        end
          else error(2)
        until sy <> comma;
        if sy <> rparent then error(4);
        insymbol
      end;
    if sy <> semicolon then error(14)
    else insymbol;
      end;
    repeat block(fsys,period,nil);
      if sy <> period then error(21)
    until (sy = period) or eof(input);
    if list then writeln(output);
    if errinx <> 0 then
      begin list := false; endofline end
  end (*programme*) ;


  procedure stdnames;
  begin
    na[ 1] := 'false   '; na[ 2] := 'true    '; na[ 3] := 'input   ';
    na[ 4] := 'output  '; na[ 5] := 'get     '; na[ 6] := 'put     ';
    na[ 7] := 'reset   '; na[ 8] := 'rewrite '; na[ 9] := 'read    ';
    na[10] := 'write   '; na[11] := 'pack    '; na[12] := 'unpack  ';
    na[13] := 'new     '; na[14] := 'release '; na[15] := 'readln  ';
    na[16] := 'writeln ';
    na[17] := 'abs     '; na[18] := 'sqr     '; na[19] := 'trunc   ';
    na[20] := 'odd     '; na[21] := 'ord     '; na[22] := 'chr     ';
    na[23] := 'pred    '; na[24] := 'succ    '; na[25] := 'eof     ';
    na[26] := 'eoln    ';
    na[27] := 'sin     '; na[28] := 'cos     '; na[29] := 'exp     ';
    na[30] := 'sqrt    '; na[31] := 'ln      '; na[32] := 'arctan  ';
    na[33] := 'prd     '; na[34] := 'prr     '; na[35] := 'mark    ';
  end (*stdnames*) ;

  procedure enterstdtypes;

  begin                         (*type underlying:*)
                            (******************)

    new(intptr,scalar,standard);                  (*integer*)
    with intptr^ do
      begin size := intsize; form := scalar; scalkind := standard end;
    new(realptr,scalar,standard);                 (*real*)
    with realptr^ do
      begin size := realsize; form := scalar; scalkind := standard end;
    new(charptr,scalar,standard);                 (*char*)
    with charptr^ do
      begin size := charsize; form := scalar; scalkind := standard end;
    new(boolptr,scalar,declared);                 (*boolean*)
    with boolptr^ do
      begin size := boolsize; form := scalar; scalkind := declared end;
    new(nilptr,pointer);                      (*nil*)
    with nilptr^ do
      begin eltype := nil; size := ptrsize; form := pointer end;
    new(parmptr,scalar,standard); (*for alignment of parameters*)
    with parmptr^ do
      begin size := parmsize; form := scalar; scalkind := standard end ;
    new(textptr,files);                       (*text*)
    with textptr^ do
      begin filtype := charptr; size := charsize; form := files end
  end (*enterstdtypes*) ;

  procedure entstdnames;
    var cp,cp1: ctp; i: integer;
  begin                               (*name:*)
                                  (*******)

    new(cp,types);                        (*integer*)
    with cp^ do
      begin name := 'integer '; idtype := intptr; klass := types end;
    enterid(cp);
    new(cp,types);                        (*real*)
    with cp^ do
      begin name := 'real    '; idtype := realptr; klass := types end;
    enterid(cp);
    new(cp,types);                        (*char*)
    with cp^ do
      begin name := 'char    '; idtype := charptr; klass := types end;
    enterid(cp);
    new(cp,types);                        (*boolean*)
    with cp^ do
      begin name := 'boolean '; idtype := boolptr; klass := types end;
    enterid(cp);
    cp1 := nil;
    for i := 1 to 2 do
      begin new(cp,konst);                    (*false,true*)
    with cp^ do
      begin name := na[i]; idtype := boolptr;
        next := cp1; values.ival := i - 1; klass := konst
      end;
    enterid(cp); cp1 := cp
      end;
    boolptr^.fconst := cp;
    new(cp,konst);                        (*nil*)
    with cp^ do
      begin name := 'nil     '; idtype := nilptr;
    next := nil; values.ival := 0; klass := konst
      end;
    enterid(cp);
    for i := 3 to 4 do
      begin new(cp,vars);                     (*input,output*)
    with cp^ do
      begin name := na[i]; idtype := textptr; klass := vars;
        vkind := actual; next := nil; vlev := 1;
        vaddr := lcaftermarkstack+(i-3)*charmax;
      end;
    enterid(cp)
      end;
    for i:=33 to 34 do
      begin new(cp,vars);                     (*prd,prr files*)
     with cp^ do
       begin name := na[i]; idtype := textptr; klass := vars;
          vkind := actual; next := nil; vlev := 1;
          vaddr := lcaftermarkstack+(i-31)*charmax;
       end;
     enterid(cp)
      end;
    for i := 5 to 16 do
      begin new(cp,proc,standard);                (*get,put,reset*)
    with cp^ do                       (*rewrite,read*)
      begin name := na[i]; idtype := nil;         (*write,pack*)
        next := nil; key := i - 4;            (*unpack,pack*)
        klass := proc; pfdeckind := standard
      end;
    enterid(cp)
      end;
    new(cp,proc,standard);
    with cp^ do
      begin name:=na[35]; idtype:=nil;
        next:= nil; key:=13;
        klass:=proc; pfdeckind:= standard
      end; enterid(cp);
    for i := 17 to 26 do
      begin new(cp,func,standard);                (*abs,sqr,trunc*)
    with cp^ do                       (*odd,ord,chr*)
      begin name := na[i]; idtype := nil;         (*pred,succ,eof*)
        next := nil; key := i - 16;
        klass := func; pfdeckind := standard
      end;
    enterid(cp)
      end;
    new(cp,vars);              (*parameter of predeclared functions*)
    with cp^ do
      begin name := '        '; idtype := realptr; klass := vars;
    vkind := actual; next := nil; vlev := 1; vaddr := 0
      end;
    for i := 27 to 32 do
      begin new(cp1,func,declared,actual);            (*sin,cos,exp*)
    with cp1^ do                      (*sqrt,ln,arctan*)
      begin name := na[i]; idtype := realptr; next := cp;
        forwdecl := false; externl := true; pflev := 0; pfname := i - 12;
        klass := func; pfdeckind := declared; pfkind := actual
      end;
    enterid(cp1)
      end
  end (*entstdnames*) ;

  procedure enterundecl;
  begin
    new(utypptr,types);
    with utypptr^ do
      begin name := '        '; idtype := nil; klass := types end;
    new(ucstptr,konst);
    with ucstptr^ do
      begin name := '        '; idtype := nil; next := nil;
    values.ival := 0; klass := konst
      end;
    new(uvarptr,vars);
    with uvarptr^ do
      begin name := '        '; idtype := nil; vkind := actual;
    next := nil; vlev := 0; vaddr := 0; klass := vars
      end;
    new(ufldptr,field);
    with ufldptr^ do
      begin name := '        '; idtype := nil; next := nil; fldaddr := 0;
    klass := field
      end;
    new(uprcptr,proc,declared,actual);
    with uprcptr^ do
      begin name := '        '; idtype := nil; forwdecl := false;
    next := nil; externl := false; pflev := 0; genlabel(pfname);
    klass := proc; pfdeckind := declared; pfkind := actual
      end;
    new(ufctptr,func,declared,actual);
    with ufctptr^ do
      begin name := '        '; idtype := nil; next := nil;
    forwdecl := false; externl := false; pflev := 0; genlabel(pfname);
    klass := func; pfdeckind := declared; pfkind := actual
      end
  end (*enterundecl*) ;

  procedure initscalars;
  begin fwptr := nil;
    prtables := false; list := true; prcode := true; debug := true;
    dp := true; prterr := true; errinx := 0;
    intlabel := 0; kk := 8; fextfilep := nil;
    lc := lcaftermarkstack+filebuffer*charmax;
    (* note in the above reservation of buffer store for 2 text files *)
    ic := 3; eol := true; linecount := 0;
    ch := ' '; chcnt := 0;
    globtestp := nil;
    mxint10 := maxint div 10; digmax := strglgth - 1;
  end (*initscalars*) ;

  procedure initsets;
  begin
    constbegsys := [addop,intconst,realconst,stringconst,ident];
    simptypebegsys := [lparent] + constbegsys;
    typebegsys:=[arrow,packedsy,arraysy,recordsy,setsy,filesy]+simptypebegsys;
    typedels := [arraysy,recordsy,setsy,filesy];
    blockbegsys := [labelsy,constsy,typesy,varsy,procsy,funcsy,beginsy];
    selectsys := [arrow,period,lbrack];
    facbegsys := [intconst,realconst,stringconst,ident,lparent,lbrack,notsy];
    statbegsys := [beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,withsy,casesy];
  end (*initsets*) ;

  procedure inittables;
    procedure reswords;
    begin
      rw[ 1] := 'if      '; rw[ 2] := 'do      '; rw[ 3] := 'of      ';
      rw[ 4] := 'to      '; rw[ 5] := 'in      '; rw[ 6] := 'or      ';
      rw[ 7] := 'end     '; rw[ 8] := 'for     '; rw[ 9] := 'var     ';
      rw[10] := 'div     '; rw[11] := 'mod     '; rw[12] := 'set     ';
      rw[13] := 'and     '; rw[14] := 'not     '; rw[15] := 'then    ';
      rw[16] := 'else    '; rw[17] := 'with    '; rw[18] := 'goto    ';
      rw[19] := 'case    '; rw[20] := 'type    ';
      rw[21] := 'file    '; rw[22] := 'begin   ';
      rw[23] := 'until   '; rw[24] := 'while   '; rw[25] := 'array   ';
      rw[26] := 'const   '; rw[27] := 'label   ';
      rw[28] := 'repeat  '; rw[29] := 'record  '; rw[30] := 'downto  ';
      rw[31] := 'packed  '; rw[32] := 'forward '; rw[33] := 'program ';
      rw[34] := 'function'; rw[35] := 'procedur';
      frw[1] :=  1; frw[2] :=  1; frw[3] :=  7; frw[4] := 15; frw[5] := 22;
      frw[6] := 28; frw[7] := 32; frw[8] := 34; frw[9] := 36;
    end (*reswords*) ;

    procedure symbols;
    begin
      rsy[ 1] := ifsy;      rsy[ 2] := dosy;      rsy[ 3] := ofsy;
      rsy[ 4] := tosy;      rsy[ 5] := relop;     rsy[ 6] := addop;
      rsy[ 7] := endsy;     rsy[ 8] := forsy;     rsy[ 9] := varsy;
      rsy[10] := mulop;     rsy[11] := mulop;     rsy[12] := setsy;
      rsy[13] := mulop;     rsy[14] := notsy;     rsy[15] := thensy;
      rsy[16] := elsesy;    rsy[17] := withsy;    rsy[18] := gotosy;
      rsy[19] := casesy;    rsy[20] := typesy;
      rsy[21] := filesy;    rsy[22] := beginsy;
      rsy[23] := untilsy;   rsy[24] := whilesy;   rsy[25] := arraysy;
      rsy[26] := constsy;   rsy[27] := labelsy;
      rsy[28] := repeatsy;  rsy[29] := recordsy;  rsy[30] := downtosy;
      rsy[31] := packedsy;  rsy[32] := forwardsy; rsy[33] := progsy;
      rsy[34] := funcsy;    rsy[35] := procsy;
      ssy['+'] := addop ;   ssy['-'] := addop;    ssy['*'] := mulop;
      ssy['/'] := mulop ;   ssy['('] := lparent;  ssy[')'] := rparent;
      ssy['$'] := othersy ; ssy['='] := relop;    ssy[' '] := othersy;
      ssy[','] := comma ;   ssy['.'] := period;   ssy['''']:= othersy;
      ssy['['] := lbrack ;  ssy[']'] := rbrack;   ssy[':'] := colon;
      ssy['^'] := arrow ;   ssy['<'] := relop;    ssy['>'] := relop;
      ssy[';'] := semicolon;
    end (*symbols*) ;

    procedure rators;
      var i: integer;
    begin
      for i := 1 to 35 (*nr of res words*) do rop[i] := noop;
      rop[5] := inop; rop[10] := idiv; rop[11] := imod;
      rop[6] := orop; rop[13] := andop;
      for i := ordminchar to ordmaxchar do sop[chr(i)] := noop;
      sop['+'] := plus; sop['-'] := minus; sop['*'] := mul; sop['/'] := rdiv;
      sop['='] := eqop; sop['<'] := ltop;  sop['>'] := gtop;
    end (*rators*) ;

    procedure procmnemonics;
    begin
      sna[ 1] :=' get'; sna[ 2] :=' put'; sna[ 3] :=' rdi'; sna[ 4] :=' rdr';
      sna[ 5] :=' rdc'; sna[ 6] :=' wri'; sna[ 7] :=' wro'; sna[ 8] :=' wrr';
      sna[ 9] :=' wrc'; sna[10] :=' wrs'; sna[11] :=' pak'; sna[12] :=' new';
      sna[13] :=' rst'; sna[14] :=' eln'; sna[15] :=' sin'; sna[16] :=' cos';
      sna[17] :=' exp'; sna[18] :=' sqt'; sna[19] :=' log'; sna[20] :=' atn';
      sna[21] :=' rln'; sna[22] :=' wln'; sna[23] :=' sav';
    end (*procmnemonics*) ;

    procedure instrmnemonics;
    begin
      mn[ 0] :=' abi'; mn[ 1] :=' abr'; mn[ 2] :=' adi'; mn[ 3] :=' adr';
      mn[ 4] :=' and'; mn[ 5] :=' dif'; mn[ 6] :=' dvi'; mn[ 7] :=' dvr';
      mn[ 8] :=' eof'; mn[ 9] :=' flo'; mn[10] :=' flt'; mn[11] :=' inn';
      mn[12] :=' int'; mn[13] :=' ior'; mn[14] :=' mod'; mn[15] :=' mpi';
      mn[16] :=' mpr'; mn[17] :=' ngi'; mn[18] :=' ngr'; mn[19] :=' not';
      mn[20] :=' odd'; mn[21] :=' sbi'; mn[22] :=' sbr'; mn[23] :=' sgs';
      mn[24] :=' sqi'; mn[25] :=' sqr'; mn[26] :=' sto'; mn[27] :=' trc';
      mn[28] :=' uni'; mn[29] :=' stp'; mn[30] :=' csp'; mn[31] :=' dec';
      mn[32] :=' ent'; mn[33] :=' fjp'; mn[34] :=' inc'; mn[35] :=' ind';
      mn[36] :=' ixa'; mn[37] :=' lao'; mn[38] :=' lca'; mn[39] :=' ldo';
      mn[40] :=' mov'; mn[41] :=' mst'; mn[42] :=' ret'; mn[43] :=' sro';
      mn[44] :=' xjp'; mn[45] :=' chk'; mn[46] :=' cup'; mn[47] :=' equ';
      mn[48] :=' geq'; mn[49] :=' grt'; mn[50] :=' lda'; mn[51] :=' ldc';
      mn[52] :=' leq'; mn[53] :=' les'; mn[54] :=' lod'; mn[55] :=' neq';
      mn[56] :=' str'; mn[57] :=' ujp'; mn[58] :=' ord'; mn[59] :=' chr';
      mn[60] :=' ujc';
    end (*instrmnemonics*) ;

    procedure chartypes;
    var i : integer;
    begin
      for i := ordminchar to ordmaxchar do chartp[chr(i)] := illegal;
      chartp['a'] := letter  ;
      chartp['b'] := letter  ; chartp['c'] := letter  ;
      chartp['d'] := letter  ; chartp['e'] := letter  ;
      chartp['f'] := letter  ; chartp['g'] := letter  ;
      chartp['h'] := letter  ; chartp['i'] := letter  ;
      chartp['j'] := letter  ; chartp['k'] := letter  ;
      chartp['l'] := letter  ; chartp['m'] := letter  ;
      chartp['n'] := letter  ; chartp['o'] := letter  ;
      chartp['p'] := letter  ; chartp['q'] := letter  ;
      chartp['r'] := letter  ; chartp['s'] := letter  ;
      chartp['t'] := letter  ; chartp['u'] := letter  ;
      chartp['v'] := letter  ; chartp['w'] := letter  ;
      chartp['x'] := letter  ; chartp['y'] := letter  ;
      chartp['z'] := letter  ; chartp['0'] := number  ;
      chartp['1'] := number  ; chartp['2'] := number  ;
      chartp['3'] := number  ; chartp['4'] := number  ;
      chartp['5'] := number  ; chartp['6'] := number  ;
      chartp['7'] := number  ; chartp['8'] := number  ;
      chartp['9'] := number  ; chartp['+'] := special ;
      chartp['-'] := special ; chartp['*'] := special ;
      chartp['/'] := special ; chartp['('] := chlparen;
      chartp[')'] := special ; chartp['$'] := special ;
      chartp['='] := special ; chartp[' '] := chspace ;
      chartp[','] := special ; chartp['.'] := chperiod;
      chartp['''']:= chstrquo; chartp['['] := special ;
      chartp[']'] := special ; chartp[':'] := chcolon ;
      chartp['^'] := special ; chartp[';'] := special ;
      chartp['<'] := chlt    ; chartp['>'] := chgt    ;
      ordint['0'] := 0; ordint['1'] := 1; ordint['2'] := 2;
      ordint['3'] := 3; ordint['4'] := 4; ordint['5'] := 5;
      ordint['6'] := 6; ordint['7'] := 7; ordint['8'] := 8;
      ordint['9'] := 9;
    end;

    procedure initdx;
    begin
      cdx[ 0] :=  0; cdx[ 1] :=  0; cdx[ 2] := -1; cdx[ 3] := -1;
      cdx[ 4] := -1; cdx[ 5] := -1; cdx[ 6] := -1; cdx[ 7] := -1;
      cdx[ 8] :=  0; cdx[ 9] :=  0; cdx[10] :=  0; cdx[11] := -1;
      cdx[12] := -1; cdx[13] := -1; cdx[14] := -1; cdx[15] := -1;
      cdx[16] := -1; cdx[17] :=  0; cdx[18] :=  0; cdx[19] :=  0;
      cdx[20] :=  0; cdx[21] := -1; cdx[22] := -1; cdx[23] :=  0;
      cdx[24] :=  0; cdx[25] :=  0; cdx[26] := -2; cdx[27] :=  0;
      cdx[28] := -1; cdx[29] :=  0; cdx[30] :=  0; cdx[31] :=  0;
      cdx[32] :=  0; cdx[33] := -1; cdx[34] :=  0; cdx[35] :=  0;
      cdx[36] := -1; cdx[37] := +1; cdx[38] := +1; cdx[39] := +1;
      cdx[40] := -2; cdx[41] :=  0; cdx[42] :=  0; cdx[43] := -1;
      cdx[44] := -1; cdx[45] :=  0; cdx[46] :=  0; cdx[47] := -1;
      cdx[48] := -1; cdx[49] := -1; cdx[50] := +1; cdx[51] := +1;
      cdx[52] := -1; cdx[53] := -1; cdx[54] := +1; cdx[55] := -1;
      cdx[56] := -1; cdx[57] :=  0; cdx[58] :=  0; cdx[59] :=  0;
      cdx[60] :=  0;
      pdx[ 1] := -1; pdx[ 2] := -1; pdx[ 3] := -2; pdx[ 4] := -2;
      pdx[ 5] := -2; pdx[ 6] := -3; pdx[ 7] := -3; pdx[ 8] := -3;
      pdx[ 9] := -3; pdx[10] := -4; pdx[11] :=  0; pdx[12] := -2;
      pdx[13] := -1; pdx[14] :=  0; pdx[15] :=  0; pdx[16] :=  0;
      pdx[17] :=  0; pdx[18] :=  0; pdx[19] :=  0; pdx[20] :=  0;
      pdx[21] := -1; pdx[22] := -1; pdx[23] := -1;
    end;

  begin (*inittables*)
    reswords; symbols; rators;
    instrmnemonics; procmnemonics;
    chartypes; initdx;
  end (*inittables*) ;

begin
  (*initialize*)
  (************)
  initscalars; initsets; inittables;


  (*enter standard names and standard types:*)
  (******************************************)
  level := 0; top := 0;
  with display[0] do
    begin fname := nil; flabel := nil; occur := blck end;
  enterstdtypes;   stdnames; entstdnames;   enterundecl;
  top := 1; level := 1;
  with display[1] do
    begin fname := nil; flabel := nil; occur := blck end;


  (*compile:*) rewrite(prr); (*comment this out when compiling with pcom *)
  (**********)
  insymbol;
  programme(blockbegsys+statbegsys-[casesy]);

end.